1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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
;
45 with Ghost
; use Ghost
;
47 with Nlists
; use Nlists
;
48 with Nmake
; use Nmake
;
50 with Output
; use Output
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
54 with Sinfo
; use Sinfo
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch3
; use Sem_Ch3
;
58 with Sem_Ch7
; use Sem_Ch7
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Util
; use Sem_Util
;
62 with Snames
; use Snames
;
63 with Stand
; use Stand
;
64 with Tbuild
; use Tbuild
;
65 with Ttypes
; use Ttypes
;
66 with Uintp
; use Uintp
;
68 package body Exp_Ch7
is
70 --------------------------------
71 -- Transient Scope Management --
72 --------------------------------
74 -- A transient scope is created when temporary objects are created by the
75 -- compiler. These temporary objects are allocated on the secondary stack
76 -- and the transient scope is responsible for finalizing the object when
77 -- appropriate and reclaiming the memory at the right time. The temporary
78 -- objects are generally the objects allocated to store the result of a
79 -- function returning an unconstrained or a tagged value. Expressions
80 -- needing to be wrapped in a transient scope (functions calls returning
81 -- unconstrained or tagged values) may appear in 3 different contexts which
82 -- lead to 3 different kinds of transient scope expansion:
84 -- 1. In a simple statement (procedure call, assignment, ...). In this
85 -- case the instruction is wrapped into a transient block. See
86 -- Wrap_Transient_Statement for details.
88 -- 2. In an expression of a control structure (test in a IF statement,
89 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
92 -- 3. In a expression of an object_declaration. No wrapping is possible
93 -- here, so the finalization actions, if any, are done right after the
94 -- declaration and the secondary stack deallocation is done in the
95 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
97 -- Note about functions returning tagged types: it has been decided to
98 -- always allocate their result in the secondary stack, even though is not
99 -- absolutely mandatory when the tagged type is constrained because the
100 -- caller knows the size of the returned object and thus could allocate the
101 -- result in the primary stack. An exception to this is when the function
102 -- builds its result in place, as is done for functions with inherently
103 -- limited result types for Ada 2005. In that case, certain callers may
104 -- pass the address of a constrained object as the target object for the
107 -- By allocating tagged results in the secondary stack a number of
108 -- implementation difficulties are avoided:
110 -- - If it is a dispatching function call, the computation of the size of
111 -- the result is possible but complex from the outside.
113 -- - If the returned type is controlled, the assignment of the returned
114 -- value to the anonymous object involves an Adjust, and we have no
115 -- easy way to access the anonymous object created by the back end.
117 -- - If the returned type is class-wide, this is an unconstrained type
120 -- Furthermore, the small loss in efficiency which is the result of this
121 -- decision is not such a big deal because functions returning tagged types
122 -- are not as common in practice compared to functions returning access to
125 --------------------------------------------------
126 -- Transient Blocks and Finalization Management --
127 --------------------------------------------------
129 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
;
130 -- N is a node which may generate a transient scope. Loop over the parent
131 -- pointers of N until we find the appropriate node to wrap. If it returns
132 -- Empty, it means that no transient scope is needed in this context.
134 procedure Insert_Actions_In_Scope_Around
137 Manage_SS
: Boolean);
138 -- Insert the before-actions kept in the scope stack before N, and the
139 -- after-actions after N, which must be a member of a list. If flag Clean
140 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
141 -- calls to mark and release the secondary stack.
143 function Make_Transient_Block
146 Par
: Node_Id
) return Node_Id
;
147 -- Action is a single statement or object declaration. Par is the proper
148 -- parent of the generated block. Create a transient block whose name is
149 -- the current scope and the only handled statement is Action. If Action
150 -- involves controlled objects or secondary stack usage, the corresponding
151 -- cleanup actions are performed at the end of the block.
153 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
154 -- Set the field Node_To_Be_Wrapped of the current scope
156 -- ??? The entire comment needs to be rewritten
157 -- ??? which entire comment?
159 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
160 -- Shared processing for Store_xxx_Actions_In_Scope
162 -----------------------------
163 -- Finalization Management --
164 -----------------------------
166 -- This part describe how Initialization/Adjustment/Finalization procedures
167 -- are generated and called. Two cases must be considered, types that are
168 -- Controlled (Is_Controlled flag set) and composite types that contain
169 -- controlled components (Has_Controlled_Component flag set). In the first
170 -- case the procedures to call are the user-defined primitive operations
171 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
172 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
173 -- of calling the former procedures on the controlled components.
175 -- For records with Has_Controlled_Component set, a hidden "controller"
176 -- component is inserted. This controller component contains its own
177 -- finalization list on which all controlled components are attached
178 -- creating an indirection on the upper-level Finalization list. This
179 -- technique facilitates the management of objects whose number of
180 -- controlled components changes during execution. This controller
181 -- component is itself controlled and is attached to the upper-level
182 -- finalization chain. Its adjust primitive is in charge of calling adjust
183 -- on the components and adjusting the finalization pointer to match their
184 -- new location (see a-finali.adb).
186 -- It is not possible to use a similar technique for arrays that have
187 -- Has_Controlled_Component set. In this case, deep procedures are
188 -- generated that call initialize/adjust/finalize + attachment or
189 -- detachment on the finalization list for all component.
191 -- Initialize calls: they are generated for declarations or dynamic
192 -- allocations of Controlled objects with no initial value. They are always
193 -- followed by an attachment to the current Finalization Chain. For the
194 -- dynamic allocation case this the chain attached to the scope of the
195 -- access type definition otherwise, this is the chain of the current
198 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
199 -- or dynamic allocations of Controlled objects with an initial value.
200 -- (2) after an assignment. In the first case they are followed by an
201 -- attachment to the final chain, in the second case they are not.
203 -- Finalization Calls: They are generated on (1) scope exit, (2)
204 -- assignments, (3) unchecked deallocations. In case (3) they have to
205 -- be detached from the final chain, in case (2) they must not and in
206 -- case (1) this is not important since we are exiting the scope anyway.
210 -- Type extensions will have a new record controller at each derivation
211 -- level containing controlled components. The record controller for
212 -- the parent/ancestor is attached to the finalization list of the
213 -- extension's record controller (i.e. the parent is like a component
214 -- of the extension).
216 -- For types that are both Is_Controlled and Has_Controlled_Components,
217 -- the record controller and the object itself are handled separately.
218 -- It could seem simpler to attach the object at the end of its record
219 -- controller but this would not tackle view conversions properly.
221 -- A classwide type can always potentially have controlled components
222 -- but the record controller of the corresponding actual type may not
223 -- be known at compile time so the dispatch table contains a special
224 -- field that allows computation of the offset of the record controller
225 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
227 -- Here is a simple example of the expansion of a controlled block :
231 -- Y : Controlled := Init;
237 -- Z : R := (C => X);
247 -- _L : System.FI.Finalizable_Ptr;
249 -- procedure _Clean is
252 -- System.FI.Finalize_List (_L);
260 -- Attach_To_Final_List (_L, Finalizable (X), 1);
261 -- at end: Abort_Undefer;
262 -- Y : Controlled := Init;
264 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
272 -- Deep_Initialize (W, _L, 1);
273 -- at end: Abort_Under;
274 -- Z : R := (C => X);
275 -- Deep_Adjust (Z, _L, 1);
279 -- Deep_Finalize (W, False);
280 -- <save W's final pointers>
282 -- <restore W's final pointers>
283 -- Deep_Adjust (W, _L, 0);
288 type Final_Primitives
is
289 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
290 -- This enumeration type is defined in order to ease sharing code for
291 -- building finalization procedures for composite types.
293 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
294 (Initialize_Case
=> Name_Initialize
,
295 Adjust_Case
=> Name_Adjust
,
296 Finalize_Case
=> Name_Finalize
,
297 Address_Case
=> Name_Finalize_Address
);
298 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
299 (Initialize_Case
=> TSS_Deep_Initialize
,
300 Adjust_Case
=> TSS_Deep_Adjust
,
301 Finalize_Case
=> TSS_Deep_Finalize
,
302 Address_Case
=> TSS_Finalize_Address
);
304 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
305 -- Determine whether access type Typ may have a finalization master
307 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
308 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
309 -- Has_Controlled_Component set and store them using the TSS mechanism.
311 function Build_Cleanup_Statements
313 Additional_Cleanup
: List_Id
) return List_Id
;
314 -- Create the clean up calls for an asynchronous call block, task master,
315 -- protected subprogram body, task allocation block or task body, or
316 -- additional cleanup actions parked on a transient block. If the context
317 -- does not contain the above constructs, the routine returns an empty
320 procedure Build_Finalizer
322 Clean_Stmts
: List_Id
;
325 Defer_Abort
: Boolean;
326 Fin_Id
: out Entity_Id
);
327 -- N may denote an accept statement, block, entry body, package body,
328 -- package spec, protected body, subprogram body, or a task body. Create
329 -- a procedure which contains finalization calls for all controlled objects
330 -- declared in the declarative or statement region of N. The calls are
331 -- built in reverse order relative to the original declarations. In the
332 -- case of a task body, the routine delays the creation of the finalizer
333 -- until all statements have been moved to the task body procedure.
334 -- Clean_Stmts may contain additional context-dependent code used to abort
335 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
336 -- Mark_Id is the secondary stack used in the current context or Empty if
337 -- missing. Top_Decls is the list on which the declaration of the finalizer
338 -- is attached in the non-package case. Defer_Abort indicates that the
339 -- statements passed in perform actions that require abort to be deferred,
340 -- such as for task termination. Fin_Id is the finalizer declaration
343 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
344 -- N is a construct which contains a handled sequence of statements, Fin_Id
345 -- is the entity of a finalizer. Create an At_End handler which covers the
346 -- statements of N and calls Fin_Id. If the handled statement sequence has
347 -- an exception handler, the statements will be wrapped in a block to avoid
348 -- unwanted interaction with the new At_End handler.
350 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
351 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
352 -- Has_Component_Component set and store them using the TSS mechanism.
354 procedure Check_Visibly_Controlled
355 (Prim
: Final_Primitives
;
357 E
: in out Entity_Id
;
358 Cref
: in out Node_Id
);
359 -- The controlled operation declared for a derived type may not be
360 -- overriding, if the controlled operations of the parent type are hidden,
361 -- for example when the parent is a private type whose full view is
362 -- controlled. For other primitive operations we modify the name of the
363 -- operation to indicate that it is not overriding, but this is not
364 -- possible for Initialize, etc. because they have to be retrievable by
365 -- name. Before generating the proper call to one of these operations we
366 -- check whether Typ is known to be controlled at the point of definition.
367 -- If it is not then we must retrieve the hidden operation of the parent
368 -- and use it instead. This is one case that might be solved more cleanly
369 -- once Overriding pragmas or declarations are in place.
371 function Convert_View
374 Ind
: Pos
:= 1) return Node_Id
;
375 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
376 -- argument being passed to it. Ind indicates which formal of procedure
377 -- Proc we are trying to match. This function will, if necessary, generate
378 -- a conversion between the partial and full view of Arg to match the type
379 -- of the formal of Proc, or force a conversion to the class-wide type in
380 -- the case where the operation is abstract.
382 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
383 -- Given an arbitrary entity, traverse the scope chain looking for the
384 -- first enclosing function. Return Empty if no function was found.
390 Skip_Self
: Boolean := False) return Node_Id
;
391 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
392 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
393 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
394 -- action has an effect on the components only (if any).
396 function Make_Deep_Proc
397 (Prim
: Final_Primitives
;
399 Stmts
: List_Id
) return Node_Id
;
400 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
401 -- Deep_Finalize procedures according to the first parameter, these
402 -- procedures operate on the type Typ. The Stmts parameter gives the body
405 function Make_Deep_Array_Body
406 (Prim
: Final_Primitives
;
407 Typ
: Entity_Id
) return List_Id
;
408 -- This function generates the list of statements for implementing
409 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
410 -- the first parameter, these procedures operate on the array type Typ.
412 function Make_Deep_Record_Body
413 (Prim
: Final_Primitives
;
415 Is_Local
: Boolean := False) return List_Id
;
416 -- This function generates the list of statements for implementing
417 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
418 -- the first parameter, these procedures operate on the record type Typ.
419 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
420 -- whether the inner logic should be dictated by state counters.
422 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
423 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
424 -- Make_Deep_Record_Body. Generate the following statements:
427 -- type Acc_Typ is access all Typ;
428 -- for Acc_Typ'Storage_Size use 0;
430 -- [Deep_]Finalize (Acc_Typ (V).all);
433 --------------------------------
434 -- Allows_Finalization_Master --
435 --------------------------------
437 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
438 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
439 -- Determine whether entity E is inside a wrapper package created for
440 -- an instance of Ada.Unchecked_Deallocation.
442 ------------------------------
443 -- In_Deallocation_Instance --
444 ------------------------------
446 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
447 Pkg
: constant Entity_Id
:= Scope
(E
);
448 Par
: Node_Id
:= Empty
;
451 if Ekind
(Pkg
) = E_Package
452 and then Present
(Related_Instance
(Pkg
))
453 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
455 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
459 and then Chars
(Par
) = Name_Unchecked_Deallocation
460 and then Chars
(Scope
(Par
)) = Name_Ada
461 and then Scope
(Scope
(Par
)) = Standard_Standard
;
465 end In_Deallocation_Instance
;
469 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
470 Ptr_Typ
: constant Entity_Id
:=
471 Root_Type_Of_Full_View
(Base_Type
(Typ
));
473 -- Start of processing for Allows_Finalization_Master
476 -- Certain run-time configurations and targets do not provide support
477 -- for controlled types and therefore do not need masters.
479 if Restriction_Active
(No_Finalization
) then
482 -- Do not consider C and C++ types since it is assumed that the non-Ada
483 -- side will handle their clean up.
485 elsif Convention
(Desig_Typ
) = Convention_C
486 or else Convention
(Desig_Typ
) = Convention_CPP
490 -- Do not consider types that return on the secondary stack
492 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
493 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
497 -- Do not consider types which may never allocate an object
499 elsif No_Pool_Assigned
(Ptr_Typ
) then
502 -- Do not consider access types coming from Ada.Unchecked_Deallocation
503 -- instances. Even though the designated type may be controlled, the
504 -- access type will never participate in allocation.
506 elsif In_Deallocation_Instance
(Ptr_Typ
) then
509 -- Do not consider non-library access types when restriction
510 -- No_Nested_Finalization is in effect since masters are controlled
513 elsif Restriction_Active
(No_Nested_Finalization
)
514 and then not Is_Library_Level_Entity
(Ptr_Typ
)
518 -- Do not create finalization masters in GNATprove mode because this
519 -- causes unwanted extra expansion. A compilation in this mode must
520 -- keep the tree as close as possible to the original sources.
522 elsif GNATprove_Mode
then
525 -- Otherwise the access type may use a finalization master
530 end Allows_Finalization_Master
;
532 ----------------------------
533 -- Build_Anonymous_Master --
534 ----------------------------
536 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
537 function Create_Anonymous_Master
538 (Desig_Typ
: Entity_Id
;
540 Unit_Decl
: Node_Id
) return Entity_Id
;
541 -- Create a new anonymous finalization master for access type Ptr_Typ
542 -- with designated type Desig_Typ. The declaration of the master along
543 -- with its specialized initialization is inserted in the declarative
544 -- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl.
546 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean;
547 -- Determine whether arbitrary node N appears within the subtree rooted
550 -----------------------------
551 -- Create_Anonymous_Master --
552 -----------------------------
554 function Create_Anonymous_Master
555 (Desig_Typ
: Entity_Id
;
557 Unit_Decl
: Node_Id
) return Entity_Id
559 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
560 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Unit_Decl
);
569 -- Find the declarative list of the unit
571 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
572 Unit_Spec
:= Specification
(Unit_Decl
);
573 Decls
:= Visible_Declarations
(Unit_Spec
);
577 Set_Visible_Declarations
(Unit_Spec
, Decls
);
580 -- Package body or subprogram case
582 -- ??? A subprogram spec or body that acts as a compilation unit may
583 -- contain a formal parameter of an anonymous access-to-controlled
584 -- type initialized by an allocator.
586 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
588 -- There is no suitable place to create the anonymous master as the
589 -- subprogram is not in a declarative list.
592 Decls
:= Declarations
(Unit_Decl
);
596 Set_Declarations
(Unit_Decl
, Decls
);
600 -- Step 1: Anonymous master creation
602 -- Use a unique prefix in case the same unit requires two anonymous
603 -- masters, one for the spec (S) and one for the body (B).
605 if Ekind_In
(Unit_Id
, E_Function
, E_Package
, E_Procedure
) then
611 -- The name of the anonymous master has the following format:
613 -- [BS]scopN__scop1__chars_of_desig_typAM
615 -- The name utilizes the fully qualified name of the designated type
616 -- in case two controlled types with the same name are declared in
617 -- different scopes and both have anonymous access types.
620 Make_Defining_Identifier
(Loc
,
622 (Related_Id
=> Get_Qualified_Name
(Desig_Typ
),
626 -- Associate the anonymous master with the designated type. This
627 -- ensures that any additional anonymous access types with the same
628 -- designated type will share the same anonymous paster within the
631 Set_Anonymous_Master
(Desig_Typ
, FM_Id
);
634 -- <FM_Id> : Finalization_Master;
637 Make_Object_Declaration
(Loc
,
638 Defining_Identifier
=> FM_Id
,
640 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
642 -- Step 2: Initialization actions
646 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
649 Make_Procedure_Call_Statement
(Loc
,
651 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
652 Parameter_Associations
=> New_List
(
653 New_Occurrence_Of
(FM_Id
, Loc
),
654 Make_Attribute_Reference
(Loc
,
656 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
657 Attribute_Name
=> Name_Unrestricted_Access
)));
659 Prepend_To
(Decls
, FM_Init
);
660 Prepend_To
(Decls
, FM_Decl
);
662 -- Since the anonymous master and all its initialization actions are
663 -- inserted at top level, use the scope of the unit when analyzing.
665 Push_Scope
(Spec_Id
);
671 end Create_Anonymous_Master
;
677 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
681 -- Traverse the parent chain until reaching the same root
684 while Present
(Par
) loop
697 Desig_Typ
: Entity_Id
;
699 Priv_View
: Entity_Id
;
703 -- Start of processing for Build_Anonymous_Master
706 -- Nothing to do if the circumstances do not allow for a finalization
709 if not Allows_Finalization_Master
(Ptr_Typ
) then
713 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
714 Unit_Id
:= Defining_Entity
(Unit_Decl
);
716 -- The compilation unit is a package instantiation. In this case the
717 -- anonymous master is associated with the package spec as both the
718 -- spec and body appear at the same level.
720 if Nkind
(Unit_Decl
) = N_Package_Body
721 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
723 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
724 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
727 -- Use the initial declaration of the designated type when it denotes
728 -- the full view of an incomplete or private type. This ensures that
729 -- types with one and two views are treated the same.
731 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
732 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
734 if Present
(Priv_View
) then
735 Desig_Typ
:= Priv_View
;
738 FM_Id
:= Anonymous_Master
(Desig_Typ
);
740 -- The designated type already has at least one anonymous access type
741 -- pointing to it within the current unit. Reuse the anonymous master
742 -- because the designated type is the same.
745 and then In_Subtree
(Declaration_Node
(FM_Id
), Root
=> Unit_Decl
)
749 -- Otherwise the designated type lacks an anonymous master or it is
750 -- declared in a different unit. Create a brand new master.
753 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
756 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
757 end Build_Anonymous_Master
;
759 ----------------------------
760 -- Build_Array_Deep_Procs --
761 ----------------------------
763 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
767 (Prim
=> Initialize_Case
,
769 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
771 if not Is_Limited_View
(Typ
) then
774 (Prim
=> Adjust_Case
,
776 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
779 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
780 -- suppressed since these routine will not be used.
782 if not Restriction_Active
(No_Finalization
) then
785 (Prim
=> Finalize_Case
,
787 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
789 -- Create TSS primitive Finalize_Address.
793 (Prim
=> Address_Case
,
795 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
797 end Build_Array_Deep_Procs
;
799 ------------------------------
800 -- Build_Cleanup_Statements --
801 ------------------------------
803 function Build_Cleanup_Statements
805 Additional_Cleanup
: List_Id
) return List_Id
807 Is_Asynchronous_Call
: constant Boolean :=
808 Nkind
(N
) = N_Block_Statement
809 and then Is_Asynchronous_Call_Block
(N
);
810 Is_Master
: constant Boolean :=
811 Nkind
(N
) /= N_Entry_Body
812 and then Is_Task_Master
(N
);
813 Is_Protected_Body
: constant Boolean :=
814 Nkind
(N
) = N_Subprogram_Body
815 and then Is_Protected_Subprogram_Body
(N
);
816 Is_Task_Allocation
: constant Boolean :=
817 Nkind
(N
) = N_Block_Statement
818 and then Is_Task_Allocation_Block
(N
);
819 Is_Task_Body
: constant Boolean :=
820 Nkind
(Original_Node
(N
)) = N_Task_Body
;
822 Loc
: constant Source_Ptr
:= Sloc
(N
);
823 Stmts
: constant List_Id
:= New_List
;
827 if Restricted_Profile
then
829 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
831 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
835 if Restriction_Active
(No_Task_Hierarchy
) = False then
836 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
839 -- Add statements to unlock the protected object parameter and to
840 -- undefer abort. If the context is a protected procedure and the object
841 -- has entries, call the entry service routine.
843 -- NOTE: The generated code references _object, a parameter to the
846 elsif Is_Protected_Body
then
848 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
849 Conc_Typ
: Entity_Id
;
851 Param_Typ
: Entity_Id
;
854 -- Find the _object parameter representing the protected object
856 Param
:= First
(Parameter_Specifications
(Spec
));
858 Param_Typ
:= Etype
(Parameter_Type
(Param
));
860 if Ekind
(Param_Typ
) = E_Record_Type
then
861 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
864 exit when No
(Param
) or else Present
(Conc_Typ
);
868 pragma Assert
(Present
(Param
));
870 -- Historical note: In earlier versions of GNAT, there was code
871 -- at this point to generate stuff to service entry queues. It is
872 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
874 Build_Protected_Subprogram_Call_Cleanup
875 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
878 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
879 -- tasks. Other unactivated tasks are completed by Complete_Task or
882 -- NOTE: The generated code references _chain, a local object
884 elsif Is_Task_Allocation
then
887 -- Expunge_Unactivated_Tasks (_chain);
889 -- where _chain is the list of tasks created by the allocator but not
890 -- yet activated. This list will be empty unless the block completes
894 Make_Procedure_Call_Statement
(Loc
,
897 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
898 Parameter_Associations
=> New_List
(
899 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
901 -- Attempt to cancel an asynchronous entry call whenever the block which
902 -- contains the abortable part is exited.
904 -- NOTE: The generated code references Cnn, a local object
906 elsif Is_Asynchronous_Call
then
908 Cancel_Param
: constant Entity_Id
:=
909 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
912 -- If it is of type Communication_Block, this must be a protected
913 -- entry call. Generate:
915 -- if Enqueued (Cancel_Param) then
916 -- Cancel_Protected_Entry_Call (Cancel_Param);
919 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
921 Make_If_Statement
(Loc
,
923 Make_Function_Call
(Loc
,
925 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
926 Parameter_Associations
=> New_List
(
927 New_Occurrence_Of
(Cancel_Param
, Loc
))),
929 Then_Statements
=> New_List
(
930 Make_Procedure_Call_Statement
(Loc
,
933 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
934 Parameter_Associations
=> New_List
(
935 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
937 -- Asynchronous delay, generate:
938 -- Cancel_Async_Delay (Cancel_Param);
940 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
942 Make_Procedure_Call_Statement
(Loc
,
944 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
945 Parameter_Associations
=> New_List
(
946 Make_Attribute_Reference
(Loc
,
948 New_Occurrence_Of
(Cancel_Param
, Loc
),
949 Attribute_Name
=> Name_Unchecked_Access
))));
951 -- Task entry call, generate:
952 -- Cancel_Task_Entry_Call (Cancel_Param);
956 Make_Procedure_Call_Statement
(Loc
,
958 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
959 Parameter_Associations
=> New_List
(
960 New_Occurrence_Of
(Cancel_Param
, Loc
))));
965 Append_List_To
(Stmts
, Additional_Cleanup
);
967 end Build_Cleanup_Statements
;
969 -----------------------------
970 -- Build_Controlling_Procs --
971 -----------------------------
973 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
975 if Is_Array_Type
(Typ
) then
976 Build_Array_Deep_Procs
(Typ
);
977 else pragma Assert
(Is_Record_Type
(Typ
));
978 Build_Record_Deep_Procs
(Typ
);
980 end Build_Controlling_Procs
;
982 -----------------------------
983 -- Build_Exception_Handler --
984 -----------------------------
986 function Build_Exception_Handler
987 (Data
: Finalization_Exception_Data
;
988 For_Library
: Boolean := False) return Node_Id
991 Proc_To_Call
: Entity_Id
;
996 pragma Assert
(Present
(Data
.Raised_Id
));
998 if Exception_Extra_Info
999 or else (For_Library
and not Restricted_Profile
)
1001 if Exception_Extra_Info
then
1005 -- Get_Current_Excep.all
1008 Make_Function_Call
(Data
.Loc
,
1010 Make_Explicit_Dereference
(Data
.Loc
,
1013 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1020 Except
:= Make_Null
(Data
.Loc
);
1023 if For_Library
and then not Restricted_Profile
then
1024 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1025 Actuals
:= New_List
(Except
);
1028 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1030 -- The dereference occurs only when Exception_Extra_Info is true,
1031 -- and therefore Except is not null.
1035 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1036 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1042 -- if not Raised_Id then
1043 -- Raised_Id := True;
1045 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1047 -- Save_Library_Occurrence (Get_Current_Excep.all);
1052 Make_If_Statement
(Data
.Loc
,
1054 Make_Op_Not
(Data
.Loc
,
1055 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1057 Then_Statements
=> New_List
(
1058 Make_Assignment_Statement
(Data
.Loc
,
1059 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1060 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1062 Make_Procedure_Call_Statement
(Data
.Loc
,
1064 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1065 Parameter_Associations
=> Actuals
))));
1070 -- Raised_Id := True;
1073 Make_Assignment_Statement
(Data
.Loc
,
1074 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1075 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1083 Make_Exception_Handler
(Data
.Loc
,
1084 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1085 Statements
=> Stmts
);
1086 end Build_Exception_Handler
;
1088 -------------------------------
1089 -- Build_Finalization_Master --
1090 -------------------------------
1092 procedure Build_Finalization_Master
1094 For_Lib_Level
: Boolean := False;
1095 For_Private
: Boolean := False;
1096 Context_Scope
: Entity_Id
:= Empty
;
1097 Insertion_Node
: Node_Id
:= Empty
)
1099 procedure Add_Pending_Access_Type
1101 Ptr_Typ
: Entity_Id
);
1102 -- Add access type Ptr_Typ to the pending access type list for type Typ
1104 -----------------------------
1105 -- Add_Pending_Access_Type --
1106 -----------------------------
1108 procedure Add_Pending_Access_Type
1110 Ptr_Typ
: Entity_Id
)
1115 if Present
(Pending_Access_Types
(Typ
)) then
1116 List
:= Pending_Access_Types
(Typ
);
1118 List
:= New_Elmt_List
;
1119 Set_Pending_Access_Types
(Typ
, List
);
1122 Prepend_Elmt
(Ptr_Typ
, List
);
1123 end Add_Pending_Access_Type
;
1127 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1129 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1130 -- A finalization master created for a named access type is associated
1131 -- with the full view (if applicable) as a consequence of freezing. The
1132 -- full view criteria does not apply to anonymous access types because
1133 -- those cannot have a private and a full view.
1135 -- Start of processing for Build_Finalization_Master
1138 -- Nothing to do if the circumstances do not allow for a finalization
1141 if not Allows_Finalization_Master
(Typ
) then
1144 -- Various machinery such as freezing may have already created a
1145 -- finalization master.
1147 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1152 Actions
: constant List_Id
:= New_List
;
1153 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1154 Fin_Mas_Id
: Entity_Id
;
1155 Pool_Id
: Entity_Id
;
1158 -- Source access types use fixed master names since the master is
1159 -- inserted in the same source unit only once. The only exception to
1160 -- this are instances using the same access type as generic actual.
1162 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1164 Make_Defining_Identifier
(Loc
,
1165 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1167 -- Internally generated access types use temporaries as their names
1168 -- due to possible collision with identical names coming from other
1172 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1175 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1178 -- <Ptr_Typ>FM : aliased Finalization_Master;
1181 Make_Object_Declaration
(Loc
,
1182 Defining_Identifier
=> Fin_Mas_Id
,
1183 Aliased_Present
=> True,
1184 Object_Definition
=>
1185 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1187 -- Set the associated pool and primitive Finalize_Address of the new
1188 -- finalization master.
1190 -- The access type has a user-defined storage pool, use it
1192 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1193 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1195 -- Otherwise the default choice is the global storage pool
1198 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1199 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1203 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1206 Make_Procedure_Call_Statement
(Loc
,
1208 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1209 Parameter_Associations
=> New_List
(
1210 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1211 Make_Attribute_Reference
(Loc
,
1212 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1213 Attribute_Name
=> Name_Unrestricted_Access
))));
1215 -- Finalize_Address is not generated in CodePeer mode because the
1216 -- body contains address arithmetic. Skip this step.
1218 if CodePeer_Mode
then
1221 -- Associate the Finalize_Address primitive of the designated type
1222 -- with the finalization master of the access type. The designated
1223 -- type must be forzen as Finalize_Address is generated when the
1224 -- freeze node is expanded.
1226 elsif Is_Frozen
(Desig_Typ
)
1227 and then Present
(Finalize_Address
(Desig_Typ
))
1229 -- The finalization master of an anonymous access type may need
1230 -- to be inserted in a specific place in the tree. For instance:
1234 -- <finalization master of "access Comp_Typ">
1236 -- type Rec_Typ is record
1237 -- Comp : access Comp_Typ;
1240 -- <freeze node for Comp_Typ>
1241 -- <freeze node for Rec_Typ>
1243 -- Due to this oddity, the anonymous access type is stored for
1244 -- later processing (see below).
1246 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1249 -- Set_Finalize_Address
1250 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1253 Make_Set_Finalize_Address_Call
1255 Ptr_Typ
=> Ptr_Typ
));
1257 -- Otherwise the designated type is either anonymous access or a
1258 -- Taft-amendment type and has not been frozen. Store the access
1259 -- type for later processing (see Freeze_Type).
1262 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1265 -- A finalization master created for an access designating a type
1266 -- with private components is inserted before a context-dependent
1271 -- At this point both the scope of the context and the insertion
1272 -- mode must be known.
1274 pragma Assert
(Present
(Context_Scope
));
1275 pragma Assert
(Present
(Insertion_Node
));
1277 Push_Scope
(Context_Scope
);
1279 -- Treat use clauses as declarations and insert directly in front
1282 if Nkind_In
(Insertion_Node
, N_Use_Package_Clause
,
1285 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1287 Insert_Actions
(Insertion_Node
, Actions
);
1292 -- The finalization master belongs to an access result type related
1293 -- to a build-in-place function call used to initialize a library
1294 -- level object. The master must be inserted in front of the access
1295 -- result type declaration denoted by Insertion_Node.
1297 elsif For_Lib_Level
then
1298 pragma Assert
(Present
(Insertion_Node
));
1299 Insert_Actions
(Insertion_Node
, Actions
);
1301 -- Otherwise the finalization master and its initialization become a
1302 -- part of the freeze node.
1305 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1308 end Build_Finalization_Master
;
1310 ---------------------
1311 -- Build_Finalizer --
1312 ---------------------
1314 procedure Build_Finalizer
1316 Clean_Stmts
: List_Id
;
1317 Mark_Id
: Entity_Id
;
1318 Top_Decls
: List_Id
;
1319 Defer_Abort
: Boolean;
1320 Fin_Id
: out Entity_Id
)
1322 Acts_As_Clean
: constant Boolean :=
1325 (Present
(Clean_Stmts
)
1326 and then Is_Non_Empty_List
(Clean_Stmts
));
1327 Exceptions_OK
: constant Boolean :=
1328 not Restriction_Active
(No_Exception_Propagation
);
1329 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1330 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1331 For_Package
: constant Boolean :=
1332 For_Package_Body
or else For_Package_Spec
;
1333 Loc
: constant Source_Ptr
:= Sloc
(N
);
1335 -- NOTE: Local variable declarations are conservative and do not create
1336 -- structures right from the start. Entities and lists are created once
1337 -- it has been established that N has at least one controlled object.
1339 Components_Built
: Boolean := False;
1340 -- A flag used to avoid double initialization of entities and lists. If
1341 -- the flag is set then the following variables have been initialized:
1347 Counter_Id
: Entity_Id
:= Empty
;
1348 Counter_Val
: Nat
:= 0;
1349 -- Name and value of the state counter
1351 Decls
: List_Id
:= No_List
;
1352 -- Declarative region of N (if available). If N is a package declaration
1353 -- Decls denotes the visible declarations.
1355 Finalizer_Data
: Finalization_Exception_Data
;
1356 -- Data for the exception
1358 Finalizer_Decls
: List_Id
:= No_List
;
1359 -- Local variable declarations. This list holds the label declarations
1360 -- of all jump block alternatives as well as the declaration of the
1361 -- local exception occurrence and the raised flag:
1362 -- E : Exception_Occurrence;
1363 -- Raised : Boolean := False;
1364 -- L<counter value> : label;
1366 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1367 -- Insertion point for the finalizer body. Depending on the context
1368 -- (Nkind of N) and the individual grouping of controlled objects, this
1369 -- node may denote a package declaration or body, package instantiation,
1370 -- block statement or a counter update statement.
1372 Finalizer_Stmts
: List_Id
:= No_List
;
1373 -- The statement list of the finalizer body. It contains the following:
1375 -- Abort_Defer; -- Added if abort is allowed
1376 -- <call to Prev_At_End> -- Added if exists
1377 -- <cleanup statements> -- Added if Acts_As_Clean
1378 -- <jump block> -- Added if Has_Ctrl_Objs
1379 -- <finalization statements> -- Added if Has_Ctrl_Objs
1380 -- <stack release> -- Added if Mark_Id exists
1381 -- Abort_Undefer; -- Added if abort is allowed
1383 Has_Ctrl_Objs
: Boolean := False;
1384 -- A general flag which denotes whether N has at least one controlled
1387 Has_Tagged_Types
: Boolean := False;
1388 -- A general flag which indicates whether N has at least one library-
1389 -- level tagged type declaration.
1391 HSS
: Node_Id
:= Empty
;
1392 -- The sequence of statements of N (if available)
1394 Jump_Alts
: List_Id
:= No_List
;
1395 -- Jump block alternatives. Depending on the value of the state counter,
1396 -- the control flow jumps to a sequence of finalization statements. This
1397 -- list contains the following:
1399 -- when <counter value> =>
1400 -- goto L<counter value>;
1402 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1403 -- Specific point in the finalizer statements where the jump block is
1406 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1407 -- The last controlled construct encountered when processing the top
1408 -- level lists of N. This can be a nested package, an instantiation or
1409 -- an object declaration.
1411 Prev_At_End
: Entity_Id
:= Empty
;
1412 -- The previous at end procedure of the handled statements block of N
1414 Priv_Decls
: List_Id
:= No_List
;
1415 -- The private declarations of N if N is a package declaration
1417 Spec_Id
: Entity_Id
:= Empty
;
1418 Spec_Decls
: List_Id
:= Top_Decls
;
1419 Stmts
: List_Id
:= No_List
;
1421 Tagged_Type_Stmts
: List_Id
:= No_List
;
1422 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1423 -- tagged types found in N.
1425 -----------------------
1426 -- Local subprograms --
1427 -----------------------
1429 procedure Build_Components
;
1430 -- Create all entites and initialize all lists used in the creation of
1433 procedure Create_Finalizer
;
1434 -- Create the spec and body of the finalizer and insert them in the
1435 -- proper place in the tree depending on the context.
1437 procedure Process_Declarations
1439 Preprocess
: Boolean := False;
1440 Top_Level
: Boolean := False);
1441 -- Inspect a list of declarations or statements which may contain
1442 -- objects that need finalization. When flag Preprocess is set, the
1443 -- routine will simply count the total number of controlled objects in
1444 -- Decls. Flag Top_Level denotes whether the processing is done for
1445 -- objects in nested package declarations or instances.
1447 procedure Process_Object_Declaration
1449 Has_No_Init
: Boolean := False;
1450 Is_Protected
: Boolean := False);
1451 -- Generate all the machinery associated with the finalization of a
1452 -- single object. Flag Has_No_Init is used to denote certain contexts
1453 -- where Decl does not have initialization call(s). Flag Is_Protected
1454 -- is set when Decl denotes a simple protected object.
1456 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1457 -- Generate all the code necessary to unregister the external tag of a
1460 ----------------------
1461 -- Build_Components --
1462 ----------------------
1464 procedure Build_Components
is
1465 Counter_Decl
: Node_Id
;
1466 Counter_Typ
: Entity_Id
;
1467 Counter_Typ_Decl
: Node_Id
;
1470 pragma Assert
(Present
(Decls
));
1472 -- This routine might be invoked several times when dealing with
1473 -- constructs that have two lists (either two declarative regions
1474 -- or declarations and statements). Avoid double initialization.
1476 if Components_Built
then
1480 Components_Built
:= True;
1482 if Has_Ctrl_Objs
then
1484 -- Create entities for the counter, its type, the local exception
1485 -- and the raised flag.
1487 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1488 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1490 Finalizer_Decls
:= New_List
;
1492 Build_Object_Declarations
1493 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1495 -- Since the total number of controlled objects is always known,
1496 -- build a subtype of Natural with precise bounds. This allows
1497 -- the backend to optimize the case statement. Generate:
1499 -- subtype Tnn is Natural range 0 .. Counter_Val;
1502 Make_Subtype_Declaration
(Loc
,
1503 Defining_Identifier
=> Counter_Typ
,
1504 Subtype_Indication
=>
1505 Make_Subtype_Indication
(Loc
,
1506 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1508 Make_Range_Constraint
(Loc
,
1512 Make_Integer_Literal
(Loc
, Uint_0
),
1514 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1516 -- Generate the declaration of the counter itself:
1518 -- Counter : Integer := 0;
1521 Make_Object_Declaration
(Loc
,
1522 Defining_Identifier
=> Counter_Id
,
1523 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1524 Expression
=> Make_Integer_Literal
(Loc
, 0));
1526 -- Set the type of the counter explicitly to prevent errors when
1527 -- examining object declarations later on.
1529 Set_Etype
(Counter_Id
, Counter_Typ
);
1531 -- The counter and its type are inserted before the source
1532 -- declarations of N.
1534 Prepend_To
(Decls
, Counter_Decl
);
1535 Prepend_To
(Decls
, Counter_Typ_Decl
);
1537 -- The counter and its associated type must be manually analyzed
1538 -- since N has already been analyzed. Use the scope of the spec
1539 -- when inserting in a package.
1542 Push_Scope
(Spec_Id
);
1543 Analyze
(Counter_Typ_Decl
);
1544 Analyze
(Counter_Decl
);
1548 Analyze
(Counter_Typ_Decl
);
1549 Analyze
(Counter_Decl
);
1552 Jump_Alts
:= New_List
;
1555 -- If the context requires additional clean up, the finalization
1556 -- machinery is added after the clean up code.
1558 if Acts_As_Clean
then
1559 Finalizer_Stmts
:= Clean_Stmts
;
1560 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1562 Finalizer_Stmts
:= New_List
;
1565 if Has_Tagged_Types
then
1566 Tagged_Type_Stmts
:= New_List
;
1568 end Build_Components
;
1570 ----------------------
1571 -- Create_Finalizer --
1572 ----------------------
1574 procedure Create_Finalizer
is
1575 function New_Finalizer_Name
return Name_Id
;
1576 -- Create a fully qualified name of a package spec or body finalizer.
1577 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1579 ------------------------
1580 -- New_Finalizer_Name --
1581 ------------------------
1583 function New_Finalizer_Name
return Name_Id
is
1584 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1585 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1586 -- has a non-standard scope, process the scope first.
1588 ------------------------
1589 -- New_Finalizer_Name --
1590 ------------------------
1592 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1594 if Scope
(Id
) = Standard_Standard
then
1595 Get_Name_String
(Chars
(Id
));
1598 New_Finalizer_Name
(Scope
(Id
));
1599 Add_Str_To_Name_Buffer
("__");
1600 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1602 end New_Finalizer_Name
;
1604 -- Start of processing for New_Finalizer_Name
1607 -- Create the fully qualified name of the enclosing scope
1609 New_Finalizer_Name
(Spec_Id
);
1612 -- __finalize_[spec|body]
1614 Add_Str_To_Name_Buffer
("__finalize_");
1616 if For_Package_Spec
then
1617 Add_Str_To_Name_Buffer
("spec");
1619 Add_Str_To_Name_Buffer
("body");
1623 end New_Finalizer_Name
;
1627 Body_Id
: Entity_Id
;
1630 Jump_Block
: Node_Id
;
1632 Label_Id
: Entity_Id
;
1634 -- Start of processing for Create_Finalizer
1637 -- Step 1: Creation of the finalizer name
1639 -- Packages must use a distinct name for their finalizers since the
1640 -- binder will have to generate calls to them by name. The name is
1641 -- of the following form:
1643 -- xx__yy__finalize_[spec|body]
1646 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1647 Set_Has_Qualified_Name
(Fin_Id
);
1648 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1650 -- The default name is _finalizer
1654 Make_Defining_Identifier
(Loc
,
1655 Chars
=> New_External_Name
(Name_uFinalizer
));
1657 -- The visibility semantics of AT_END handlers force a strange
1658 -- separation of spec and body for stack-related finalizers:
1660 -- declare : Enclosing_Scope
1661 -- procedure _finalizer;
1663 -- <controlled objects>
1664 -- procedure _finalizer is
1670 -- Both spec and body are within the same construct and scope, but
1671 -- the body is part of the handled sequence of statements. This
1672 -- placement confuses the elaboration mechanism on targets where
1673 -- AT_END handlers are expanded into "when all others" handlers:
1676 -- when all others =>
1677 -- _finalizer; -- appears to require elab checks
1682 -- Since the compiler guarantees that the body of a _finalizer is
1683 -- always inserted in the same construct where the AT_END handler
1684 -- resides, there is no need for elaboration checks.
1686 Set_Kill_Elaboration_Checks
(Fin_Id
);
1688 -- Inlining the finalizer produces a substantial speedup at -O2.
1689 -- It is inlined by default at -O3. Either way, it is called
1690 -- exactly twice (once on the normal path, and once for
1691 -- exceptions/abort), so this won't bloat the code too much.
1693 Set_Is_Inlined
(Fin_Id
);
1696 -- Step 2: Creation of the finalizer specification
1699 -- procedure Fin_Id;
1702 Make_Subprogram_Declaration
(Loc
,
1704 Make_Procedure_Specification
(Loc
,
1705 Defining_Unit_Name
=> Fin_Id
));
1707 -- Step 3: Creation of the finalizer body
1709 if Has_Ctrl_Objs
then
1711 -- Add L0, the default destination to the jump block
1713 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1714 Set_Entity
(Label_Id
,
1715 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1716 Label
:= Make_Label
(Loc
, Label_Id
);
1721 Prepend_To
(Finalizer_Decls
,
1722 Make_Implicit_Label_Declaration
(Loc
,
1723 Defining_Identifier
=> Entity
(Label_Id
),
1724 Label_Construct
=> Label
));
1730 Append_To
(Jump_Alts
,
1731 Make_Case_Statement_Alternative
(Loc
,
1732 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1733 Statements
=> New_List
(
1734 Make_Goto_Statement
(Loc
,
1735 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1740 Append_To
(Finalizer_Stmts
, Label
);
1742 -- Create the jump block which controls the finalization flow
1743 -- depending on the value of the state counter.
1746 Make_Case_Statement
(Loc
,
1747 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1748 Alternatives
=> Jump_Alts
);
1750 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1751 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1753 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1757 -- Add the library-level tagged type unregistration machinery before
1758 -- the jump block circuitry. This ensures that external tags will be
1759 -- removed even if a finalization exception occurs at some point.
1761 if Has_Tagged_Types
then
1762 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1765 -- Add a call to the previous At_End handler if it exists. The call
1766 -- must always precede the jump block.
1768 if Present
(Prev_At_End
) then
1769 Prepend_To
(Finalizer_Stmts
,
1770 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1772 -- Clear the At_End handler since we have already generated the
1773 -- proper replacement call for it.
1775 Set_At_End_Proc
(HSS
, Empty
);
1778 -- Release the secondary stack mark
1780 if Present
(Mark_Id
) then
1781 Append_To
(Finalizer_Stmts
, Build_SS_Release_Call
(Loc
, Mark_Id
));
1784 -- Protect the statements with abort defer/undefer. This is only when
1785 -- aborts are allowed and the clean up statements require deferral or
1786 -- there are controlled objects to be finalized. Note that the abort
1787 -- defer/undefer pair does not require an extra block because each
1788 -- finalization exception is caught in its corresponding finalization
1789 -- block. As a result, the call to Abort_Defer always takes place.
1791 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1792 Prepend_To
(Finalizer_Stmts
,
1793 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1795 Append_To
(Finalizer_Stmts
,
1796 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1799 -- The local exception does not need to be reraised for library-level
1800 -- finalizers. Note that this action must be carried out after object
1801 -- clean up, secondary stack release and abort undeferral. Generate:
1803 -- if Raised and then not Abort then
1804 -- Raise_From_Controlled_Operation (E);
1807 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1808 Append_To
(Finalizer_Stmts
,
1809 Build_Raise_Statement
(Finalizer_Data
));
1813 -- procedure Fin_Id is
1814 -- Abort : constant Boolean := Triggered_By_Abort;
1816 -- Abort : constant Boolean := False; -- no abort
1818 -- E : Exception_Occurrence; -- All added if flag
1819 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1825 -- Abort_Defer; -- Added if abort is allowed
1826 -- <call to Prev_At_End> -- Added if exists
1827 -- <cleanup statements> -- Added if Acts_As_Clean
1828 -- <jump block> -- Added if Has_Ctrl_Objs
1829 -- <finalization statements> -- Added if Has_Ctrl_Objs
1830 -- <stack release> -- Added if Mark_Id exists
1831 -- Abort_Undefer; -- Added if abort is allowed
1832 -- <exception propagation> -- Added if Has_Ctrl_Objs
1835 -- Create the body of the finalizer
1837 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1840 Set_Has_Qualified_Name
(Body_Id
);
1841 Set_Has_Fully_Qualified_Name
(Body_Id
);
1845 Make_Subprogram_Body
(Loc
,
1847 Make_Procedure_Specification
(Loc
,
1848 Defining_Unit_Name
=> Body_Id
),
1849 Declarations
=> Finalizer_Decls
,
1850 Handled_Statement_Sequence
=>
1851 Make_Handled_Sequence_Of_Statements
(Loc
,
1852 Statements
=> Finalizer_Stmts
));
1854 -- Step 4: Spec and body insertion, analysis
1858 -- If the package spec has private declarations, the finalizer
1859 -- body must be added to the end of the list in order to have
1860 -- visibility of all private controlled objects.
1862 if For_Package_Spec
then
1863 if Present
(Priv_Decls
) then
1864 Append_To
(Priv_Decls
, Fin_Spec
);
1865 Append_To
(Priv_Decls
, Fin_Body
);
1867 Append_To
(Decls
, Fin_Spec
);
1868 Append_To
(Decls
, Fin_Body
);
1871 -- For package bodies, both the finalizer spec and body are
1872 -- inserted at the end of the package declarations.
1875 Append_To
(Decls
, Fin_Spec
);
1876 Append_To
(Decls
, Fin_Body
);
1879 -- Push the name of the package
1881 Push_Scope
(Spec_Id
);
1889 -- Create the spec for the finalizer. The At_End handler must be
1890 -- able to call the body which resides in a nested structure.
1894 -- procedure Fin_Id; -- Spec
1896 -- <objects and possibly statements>
1897 -- procedure Fin_Id is ... -- Body
1900 -- Fin_Id; -- At_End handler
1903 pragma Assert
(Present
(Spec_Decls
));
1905 Append_To
(Spec_Decls
, Fin_Spec
);
1908 -- When the finalizer acts solely as a clean up routine, the body
1909 -- is inserted right after the spec.
1911 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1912 Insert_After
(Fin_Spec
, Fin_Body
);
1914 -- In all other cases the body is inserted after either:
1916 -- 1) The counter update statement of the last controlled object
1917 -- 2) The last top level nested controlled package
1918 -- 3) The last top level controlled instantiation
1921 -- Manually freeze the spec. This is somewhat of a hack because
1922 -- a subprogram is frozen when its body is seen and the freeze
1923 -- node appears right before the body. However, in this case,
1924 -- the spec must be frozen earlier since the At_End handler
1925 -- must be able to call it.
1928 -- procedure Fin_Id; -- Spec
1929 -- [Fin_Id] -- Freeze node
1933 -- Fin_Id; -- At_End handler
1936 Ensure_Freeze_Node
(Fin_Id
);
1937 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1938 Set_Is_Frozen
(Fin_Id
);
1940 -- In the case where the last construct to contain a controlled
1941 -- object is either a nested package, an instantiation or a
1942 -- freeze node, the body must be inserted directly after the
1945 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1947 N_Package_Declaration
,
1950 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1953 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1958 end Create_Finalizer
;
1960 --------------------------
1961 -- Process_Declarations --
1962 --------------------------
1964 procedure Process_Declarations
1966 Preprocess
: Boolean := False;
1967 Top_Level
: Boolean := False)
1972 Obj_Typ
: Entity_Id
;
1973 Pack_Id
: Entity_Id
;
1977 Old_Counter_Val
: Nat
;
1978 -- This variable is used to determine whether a nested package or
1979 -- instance contains at least one controlled object.
1981 procedure Processing_Actions
1982 (Has_No_Init
: Boolean := False;
1983 Is_Protected
: Boolean := False);
1984 -- Depending on the mode of operation of Process_Declarations, either
1985 -- increment the controlled object counter, set the controlled object
1986 -- flag and store the last top level construct or process the current
1987 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1988 -- the current declaration may not have initialization proc(s). Flag
1989 -- Is_Protected should be set when the current declaration denotes a
1990 -- simple protected object.
1992 ------------------------
1993 -- Processing_Actions --
1994 ------------------------
1996 procedure Processing_Actions
1997 (Has_No_Init
: Boolean := False;
1998 Is_Protected
: Boolean := False)
2001 -- Library-level tagged type
2003 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2005 Has_Tagged_Types
:= True;
2007 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2008 Last_Top_Level_Ctrl_Construct
:= Decl
;
2012 Process_Tagged_Type_Declaration
(Decl
);
2015 -- Controlled object declaration
2019 Counter_Val
:= Counter_Val
+ 1;
2020 Has_Ctrl_Objs
:= True;
2022 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2023 Last_Top_Level_Ctrl_Construct
:= Decl
;
2027 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2030 end Processing_Actions
;
2032 -- Start of processing for Process_Declarations
2035 if No
(Decls
) or else Is_Empty_List
(Decls
) then
2039 -- Process all declarations in reverse order
2041 Decl
:= Last_Non_Pragma
(Decls
);
2042 while Present
(Decl
) loop
2044 -- Library-level tagged types
2046 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2047 Typ
:= Defining_Identifier
(Decl
);
2049 -- Ignored Ghost types do not need any cleanup actions because
2050 -- they will not appear in the final tree.
2052 if Is_Ignored_Ghost_Entity
(Typ
) then
2055 elsif Is_Tagged_Type
(Typ
)
2056 and then Is_Library_Level_Entity
(Typ
)
2057 and then Convention
(Typ
) = Convention_Ada
2058 and then Present
(Access_Disp_Table
(Typ
))
2059 and then RTE_Available
(RE_Register_Tag
)
2060 and then not Is_Abstract_Type
(Typ
)
2061 and then not No_Run_Time_Mode
2066 -- Regular object declarations
2068 elsif Nkind
(Decl
) = N_Object_Declaration
then
2069 Obj_Id
:= Defining_Identifier
(Decl
);
2070 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2071 Expr
:= Expression
(Decl
);
2073 -- Bypass any form of processing for objects which have their
2074 -- finalization disabled. This applies only to objects at the
2077 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2080 -- Transient variables are treated separately in order to
2081 -- minimize the size of the generated code. For details, see
2082 -- Process_Transient_Objects.
2084 elsif Is_Processed_Transient
(Obj_Id
) then
2087 -- Ignored Ghost objects do not need any cleanup actions
2088 -- because they will not appear in the final tree.
2090 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2093 -- The expansion of iterator loops generates an object
2094 -- declaration where the Ekind is explicitly set to loop
2095 -- parameter. This is to ensure that the loop parameter behaves
2096 -- as a constant from user code point of view. Such object are
2097 -- never controlled and do not require finalization.
2099 elsif Ekind
(Obj_Id
) = E_Loop_Parameter
then
2102 -- The object is of the form:
2103 -- Obj : Typ [:= Expr];
2105 -- Do not process the incomplete view of a deferred constant.
2106 -- Do not consider tag-to-class-wide conversions.
2108 elsif not Is_Imported
(Obj_Id
)
2109 and then Needs_Finalization
(Obj_Typ
)
2110 and then not (Ekind
(Obj_Id
) = E_Constant
2111 and then not Has_Completion
(Obj_Id
))
2112 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2116 -- The object is of the form:
2117 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2119 -- Obj : Access_Typ :=
2120 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2122 elsif Is_Access_Type
(Obj_Typ
)
2123 and then Needs_Finalization
2124 (Available_View
(Designated_Type
(Obj_Typ
)))
2125 and then Present
(Expr
)
2127 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2129 (Is_Non_BIP_Func_Call
(Expr
)
2130 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2132 Processing_Actions
(Has_No_Init
=> True);
2134 -- Processing for "hook" objects generated for controlled
2135 -- transients declared inside an Expression_With_Actions.
2137 elsif Is_Access_Type
(Obj_Typ
)
2138 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2139 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2140 N_Object_Declaration
2142 Processing_Actions
(Has_No_Init
=> True);
2144 -- Process intermediate results of an if expression with one
2145 -- of the alternatives using a controlled function call.
2147 elsif Is_Access_Type
(Obj_Typ
)
2148 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2149 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2150 N_Defining_Identifier
2151 and then Present
(Expr
)
2152 and then Nkind
(Expr
) = N_Null
2154 Processing_Actions
(Has_No_Init
=> True);
2156 -- Simple protected objects which use type System.Tasking.
2157 -- Protected_Objects.Protection to manage their locks should
2158 -- be treated as controlled since they require manual cleanup.
2159 -- The only exception is illustrated in the following example:
2162 -- type Ctrl is new Controlled ...
2163 -- procedure Finalize (Obj : in out Ctrl);
2167 -- package body Pkg is
2168 -- protected Prot is
2169 -- procedure Do_Something (Obj : in out Ctrl);
2172 -- protected body Prot is
2173 -- procedure Do_Something (Obj : in out Ctrl) is ...
2176 -- procedure Finalize (Obj : in out Ctrl) is
2178 -- Prot.Do_Something (Obj);
2182 -- Since for the most part entities in package bodies depend on
2183 -- those in package specs, Prot's lock should be cleaned up
2184 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2185 -- This act however attempts to invoke Do_Something and fails
2186 -- because the lock has disappeared.
2188 elsif Ekind
(Obj_Id
) = E_Variable
2189 and then not In_Library_Level_Package_Body
(Obj_Id
)
2190 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2191 or else Has_Simple_Protected_Object
(Obj_Typ
))
2193 Processing_Actions
(Is_Protected
=> True);
2196 -- Specific cases of object renamings
2198 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2199 Obj_Id
:= Defining_Identifier
(Decl
);
2200 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2202 -- Bypass any form of processing for objects which have their
2203 -- finalization disabled. This applies only to objects at the
2206 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2209 -- Ignored Ghost object renamings do not need any cleanup
2210 -- actions because they will not appear in the final tree.
2212 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2215 -- Return object of a build-in-place function. This case is
2216 -- recognized and marked by the expansion of an extended return
2217 -- statement (see Expand_N_Extended_Return_Statement).
2219 elsif Needs_Finalization
(Obj_Typ
)
2220 and then Is_Return_Object
(Obj_Id
)
2221 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2223 Processing_Actions
(Has_No_Init
=> True);
2225 -- Detect a case where a source object has been initialized by
2226 -- a controlled function call or another object which was later
2227 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2229 -- Obj1 : CW_Type := Src_Obj;
2230 -- Obj2 : CW_Type := Function_Call (...);
2232 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2233 -- Tmp : ... := Function_Call (...)'reference;
2234 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2236 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2237 Processing_Actions
(Has_No_Init
=> True);
2240 -- Inspect the freeze node of an access-to-controlled type and
2241 -- look for a delayed finalization master. This case arises when
2242 -- the freeze actions are inserted at a later time than the
2243 -- expansion of the context. Since Build_Finalizer is never called
2244 -- on a single construct twice, the master will be ultimately
2245 -- left out and never finalized. This is also needed for freeze
2246 -- actions of designated types themselves, since in some cases the
2247 -- finalization master is associated with a designated type's
2248 -- freeze node rather than that of the access type (see handling
2249 -- for freeze actions in Build_Finalization_Master).
2251 elsif Nkind
(Decl
) = N_Freeze_Entity
2252 and then Present
(Actions
(Decl
))
2254 Typ
:= Entity
(Decl
);
2256 -- Freeze nodes for ignored Ghost types do not need cleanup
2257 -- actions because they will never appear in the final tree.
2259 if Is_Ignored_Ghost_Entity
(Typ
) then
2262 elsif (Is_Access_Type
(Typ
)
2263 and then not Is_Access_Subprogram_Type
(Typ
)
2264 and then Needs_Finalization
2265 (Available_View
(Designated_Type
(Typ
))))
2266 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2268 Old_Counter_Val
:= Counter_Val
;
2270 -- Freeze nodes are considered to be identical to packages
2271 -- and blocks in terms of nesting. The difference is that
2272 -- a finalization master created inside the freeze node is
2273 -- at the same nesting level as the node itself.
2275 Process_Declarations
(Actions
(Decl
), Preprocess
);
2277 -- The freeze node contains a finalization master
2281 and then No
(Last_Top_Level_Ctrl_Construct
)
2282 and then Counter_Val
> Old_Counter_Val
2284 Last_Top_Level_Ctrl_Construct
:= Decl
;
2288 -- Nested package declarations, avoid generics
2290 elsif Nkind
(Decl
) = N_Package_Declaration
then
2291 Pack_Id
:= Defining_Entity
(Decl
);
2292 Spec
:= Specification
(Decl
);
2294 -- Do not inspect an ignored Ghost package because all code
2295 -- found within will not appear in the final tree.
2297 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2300 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2301 Old_Counter_Val
:= Counter_Val
;
2302 Process_Declarations
2303 (Private_Declarations
(Spec
), Preprocess
);
2304 Process_Declarations
2305 (Visible_Declarations
(Spec
), Preprocess
);
2307 -- Either the visible or the private declarations contain a
2308 -- controlled object. The nested package declaration is the
2309 -- last such construct.
2313 and then No
(Last_Top_Level_Ctrl_Construct
)
2314 and then Counter_Val
> Old_Counter_Val
2316 Last_Top_Level_Ctrl_Construct
:= Decl
;
2320 -- Nested package bodies, avoid generics
2322 elsif Nkind
(Decl
) = N_Package_Body
then
2324 -- Do not inspect an ignored Ghost package body because all
2325 -- code found within will not appear in the final tree.
2327 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2330 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2333 Old_Counter_Val
:= Counter_Val
;
2334 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2336 -- The nested package body is the last construct to contain
2337 -- a controlled object.
2341 and then No
(Last_Top_Level_Ctrl_Construct
)
2342 and then Counter_Val
> Old_Counter_Val
2344 Last_Top_Level_Ctrl_Construct
:= Decl
;
2348 -- Handle a rare case caused by a controlled transient variable
2349 -- created as part of a record init proc. The variable is wrapped
2350 -- in a block, but the block is not associated with a transient
2353 elsif Nkind
(Decl
) = N_Block_Statement
2354 and then Inside_Init_Proc
2356 Old_Counter_Val
:= Counter_Val
;
2358 if Present
(Handled_Statement_Sequence
(Decl
)) then
2359 Process_Declarations
2360 (Statements
(Handled_Statement_Sequence
(Decl
)),
2364 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2366 -- Either the declaration or statement list of the block has a
2367 -- controlled object.
2371 and then No
(Last_Top_Level_Ctrl_Construct
)
2372 and then Counter_Val
> Old_Counter_Val
2374 Last_Top_Level_Ctrl_Construct
:= Decl
;
2377 -- Handle the case where the original context has been wrapped in
2378 -- a block to avoid interference between exception handlers and
2379 -- At_End handlers. Treat the block as transparent and process its
2382 elsif Nkind
(Decl
) = N_Block_Statement
2383 and then Is_Finalization_Wrapper
(Decl
)
2385 if Present
(Handled_Statement_Sequence
(Decl
)) then
2386 Process_Declarations
2387 (Statements
(Handled_Statement_Sequence
(Decl
)),
2391 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2394 Prev_Non_Pragma
(Decl
);
2396 end Process_Declarations
;
2398 --------------------------------
2399 -- Process_Object_Declaration --
2400 --------------------------------
2402 procedure Process_Object_Declaration
2404 Has_No_Init
: Boolean := False;
2405 Is_Protected
: Boolean := False)
2407 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2408 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2410 Init_Typ
: Entity_Id
;
2411 -- The initialization type of the related object declaration. Note
2412 -- that this is not necessarely the same type as Obj_Typ because of
2413 -- possible type derivations.
2415 Obj_Typ
: Entity_Id
;
2416 -- The type of the related object declaration
2418 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2419 -- Func_Id denotes a build-in-place function. Generate the following
2422 -- if BIPallocfrom > Secondary_Stack'Pos
2423 -- and then BIPfinalizationmaster /= null
2426 -- type Ptr_Typ is access Obj_Typ;
2427 -- for Ptr_Typ'Storage_Pool
2428 -- use Base_Pool (BIPfinalizationmaster);
2430 -- Free (Ptr_Typ (Temp));
2434 -- Obj_Typ is the type of the current object, Temp is the original
2435 -- allocation which Obj_Id renames.
2437 procedure Find_Last_Init
2438 (Last_Init
: out Node_Id
;
2439 Body_Insert
: out Node_Id
);
2440 -- Find the last initialization call related to object declaration
2441 -- Decl. Last_Init denotes the last initialization call which follows
2442 -- Decl. Body_Insert denotes a node where the finalizer body could be
2443 -- potentially inserted after (if blocks are involved).
2445 -----------------------------
2446 -- Build_BIP_Cleanup_Stmts --
2447 -----------------------------
2449 function Build_BIP_Cleanup_Stmts
2450 (Func_Id
: Entity_Id
) return Node_Id
2452 Decls
: constant List_Id
:= New_List
;
2453 Fin_Mas_Id
: constant Entity_Id
:=
2454 Build_In_Place_Formal
2455 (Func_Id
, BIP_Finalization_Master
);
2456 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2457 Temp_Id
: constant Entity_Id
:=
2458 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2462 Free_Stmt
: Node_Id
;
2463 Pool_Id
: Entity_Id
;
2464 Ptr_Typ
: Entity_Id
;
2468 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2470 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2473 Make_Object_Renaming_Declaration
(Loc
,
2474 Defining_Identifier
=> Pool_Id
,
2476 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2478 Make_Explicit_Dereference
(Loc
,
2480 Make_Function_Call
(Loc
,
2482 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2483 Parameter_Associations
=> New_List
(
2484 Make_Explicit_Dereference
(Loc
,
2486 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2488 -- Create an access type which uses the storage pool of the
2489 -- caller's finalization master.
2492 -- type Ptr_Typ is access Func_Typ;
2494 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2497 Make_Full_Type_Declaration
(Loc
,
2498 Defining_Identifier
=> Ptr_Typ
,
2500 Make_Access_To_Object_Definition
(Loc
,
2501 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2503 -- Perform minor decoration in order to set the master and the
2504 -- storage pool attributes.
2506 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2507 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2508 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2510 -- Create an explicit free statement. Note that the free uses the
2511 -- caller's pool expressed as a renaming.
2514 Make_Free_Statement
(Loc
,
2516 Unchecked_Convert_To
(Ptr_Typ
,
2517 New_Occurrence_Of
(Temp_Id
, Loc
)));
2519 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2521 -- Create a block to house the dummy type and the instantiation as
2522 -- well as to perform the cleanup the temporary.
2528 -- Free (Ptr_Typ (Temp_Id));
2532 Make_Block_Statement
(Loc
,
2533 Declarations
=> Decls
,
2534 Handled_Statement_Sequence
=>
2535 Make_Handled_Sequence_Of_Statements
(Loc
,
2536 Statements
=> New_List
(Free_Stmt
)));
2539 -- if BIPfinalizationmaster /= null then
2543 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2544 Right_Opnd
=> Make_Null
(Loc
));
2546 -- For constrained or tagged results escalate the condition to
2547 -- include the allocation format. Generate:
2549 -- if BIPallocform > Secondary_Stack'Pos
2550 -- and then BIPfinalizationmaster /= null
2553 if not Is_Constrained
(Func_Typ
)
2554 or else Is_Tagged_Type
(Func_Typ
)
2557 Alloc
: constant Entity_Id
:=
2558 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2564 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2566 Make_Integer_Literal
(Loc
,
2568 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2570 Right_Opnd
=> Cond
);
2580 Make_If_Statement
(Loc
,
2582 Then_Statements
=> New_List
(Free_Blk
));
2583 end Build_BIP_Cleanup_Stmts
;
2585 --------------------
2586 -- Find_Last_Init --
2587 --------------------
2589 procedure Find_Last_Init
2590 (Last_Init
: out Node_Id
;
2591 Body_Insert
: out Node_Id
)
2593 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2594 -- Find the last initialization call within the statements of
2597 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2598 -- Determine whether node N denotes one of the initialization
2599 -- procedures of types Init_Typ or Obj_Typ.
2601 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2602 -- Given a statement which is part of a list, return the next
2603 -- statement while skipping over dynamic elab checks.
2605 -----------------------------
2606 -- Find_Last_Init_In_Block --
2607 -----------------------------
2609 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2610 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2614 -- Examine the individual statements of the block in reverse to
2615 -- locate the last initialization call.
2617 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2618 Stmt
:= Last
(Statements
(HSS
));
2619 while Present
(Stmt
) loop
2621 -- Peek inside nested blocks in case aborts are allowed
2623 if Nkind
(Stmt
) = N_Block_Statement
then
2624 return Find_Last_Init_In_Block
(Stmt
);
2626 elsif Is_Init_Call
(Stmt
) then
2635 end Find_Last_Init_In_Block
;
2641 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2642 function Is_Init_Proc_Of
2643 (Subp_Id
: Entity_Id
;
2644 Typ
: Entity_Id
) return Boolean;
2645 -- Determine whether subprogram Subp_Id is a valid init proc of
2648 ---------------------
2649 -- Is_Init_Proc_Of --
2650 ---------------------
2652 function Is_Init_Proc_Of
2653 (Subp_Id
: Entity_Id
;
2654 Typ
: Entity_Id
) return Boolean
2656 Deep_Init
: Entity_Id
:= Empty
;
2657 Prim_Init
: Entity_Id
:= Empty
;
2658 Type_Init
: Entity_Id
:= Empty
;
2661 -- Obtain all possible initialization routines of the
2662 -- related type and try to match the subprogram entity
2663 -- against one of them.
2667 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2669 -- Primitive Initialize
2671 if Is_Controlled
(Typ
) then
2672 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2674 if Present
(Prim_Init
) then
2675 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2679 -- Type initialization routine
2681 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2682 Type_Init
:= Base_Init_Proc
(Typ
);
2686 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2688 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2690 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2691 end Is_Init_Proc_Of
;
2695 Call_Id
: Entity_Id
;
2697 -- Start of processing for Is_Init_Call
2700 if Nkind
(N
) = N_Procedure_Call_Statement
2701 and then Nkind
(Name
(N
)) = N_Identifier
2703 Call_Id
:= Entity
(Name
(N
));
2705 -- Consider both the type of the object declaration and its
2706 -- related initialization type.
2709 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2711 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2717 -----------------------------
2718 -- Next_Suitable_Statement --
2719 -----------------------------
2721 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2722 Result
: Node_Id
:= Next
(Stmt
);
2725 -- Skip over access-before-elaboration checks
2727 if Dynamic_Elaboration_Checks
2728 and then Nkind
(Result
) = N_Raise_Program_Error
2730 Result
:= Next
(Result
);
2734 end Next_Suitable_Statement
;
2742 Deep_Init_Found
: Boolean := False;
2743 -- A flag set when a call to [Deep_]Initialize has been found
2745 -- Start of processing for Find_Last_Init
2749 Body_Insert
:= Empty
;
2751 -- Object renamings and objects associated with controlled
2752 -- function results do not require initialization.
2758 Stmt
:= Next_Suitable_Statement
(Decl
);
2760 -- A limited controlled object initialized by a function call uses
2761 -- the build-in-place machinery to obtain its value.
2763 -- Obj : Lim_Controlled_Type := Func_Call;
2767 -- Obj : Lim_Controlled_Type;
2768 -- type Ptr_Typ is access Lim_Controlled_Type;
2769 -- Temp : constant Ptr_Typ :=
2772 -- BIPaccess => Obj'Unrestricted_Access)'reference;
2774 -- In this scenario the declaration of the temporary acts as the
2775 -- last initialization statement.
2777 if Is_Limited_Type
(Obj_Typ
)
2778 and then Has_Init_Expression
(Decl
)
2779 and then No
(Expression
(Decl
))
2781 while Present
(Stmt
) loop
2782 if Nkind
(Stmt
) = N_Object_Declaration
2783 and then Present
(Expression
(Stmt
))
2784 and then Is_Object_Access_BIP_Func_Call
2785 (Expr
=> Expression
(Stmt
),
2795 -- Nothing to do for an object with supporessed initialization.
2796 -- Note that this check is not performed at the beginning of the
2797 -- routine because a declaration marked with No_Initialization
2798 -- may still be initialized by a build-in-place call (the case
2801 elsif No_Initialization
(Decl
) then
2804 -- In all other cases the initialization calls follow the related
2805 -- object. The general structure of object initialization built by
2806 -- routine Default_Initialize_Object is as follows:
2808 -- [begin -- aborts allowed
2810 -- Type_Init_Proc (Obj);
2811 -- [begin] -- exceptions allowed
2812 -- Deep_Initialize (Obj);
2813 -- [exception -- exceptions allowed
2815 -- Deep_Finalize (Obj, Self => False);
2818 -- [at end -- aborts allowed
2822 -- When aborts are allowed, the initialization calls are housed
2825 elsif Nkind
(Stmt
) = N_Block_Statement
then
2826 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2827 Body_Insert
:= Stmt
;
2829 -- Otherwise the initialization calls follow the related object
2832 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2834 -- Check for an optional call to Deep_Initialize which may
2835 -- appear within a block depending on whether the object has
2836 -- controlled components.
2838 if Present
(Stmt_2
) then
2839 if Nkind
(Stmt_2
) = N_Block_Statement
then
2840 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2842 if Present
(Call
) then
2843 Deep_Init_Found
:= True;
2845 Body_Insert
:= Stmt_2
;
2848 elsif Is_Init_Call
(Stmt_2
) then
2849 Deep_Init_Found
:= True;
2850 Last_Init
:= Stmt_2
;
2851 Body_Insert
:= Last_Init
;
2855 -- If the object lacks a call to Deep_Initialize, then it must
2856 -- have a call to its related type init proc.
2858 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2860 Body_Insert
:= Last_Init
;
2868 Count_Ins
: Node_Id
;
2870 Fin_Stmts
: List_Id
;
2873 Label_Id
: Entity_Id
;
2876 -- Start of processing for Process_Object_Declaration
2879 -- Handle the object type and the reference to the object
2881 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2882 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2885 if Is_Access_Type
(Obj_Typ
) then
2886 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2887 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2889 elsif Is_Concurrent_Type
(Obj_Typ
)
2890 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2892 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2893 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2895 elsif Is_Private_Type
(Obj_Typ
)
2896 and then Present
(Full_View
(Obj_Typ
))
2898 Obj_Typ
:= Full_View
(Obj_Typ
);
2899 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2901 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2902 Obj_Typ
:= Base_Type
(Obj_Typ
);
2903 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2910 Set_Etype
(Obj_Ref
, Obj_Typ
);
2912 -- Handle the initialization type of the object declaration
2914 Init_Typ
:= Obj_Typ
;
2916 if Is_Private_Type
(Init_Typ
)
2917 and then Present
(Full_View
(Init_Typ
))
2919 Init_Typ
:= Full_View
(Init_Typ
);
2921 elsif Is_Untagged_Derivation
(Init_Typ
) then
2922 Init_Typ
:= Root_Type
(Init_Typ
);
2929 -- Set a new value for the state counter and insert the statement
2930 -- after the object declaration. Generate:
2932 -- Counter := <value>;
2935 Make_Assignment_Statement
(Loc
,
2936 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2937 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2939 -- Insert the counter after all initialization has been done. The
2940 -- place of insertion depends on the context. If an object is being
2941 -- initialized via an aggregate, then the counter must be inserted
2942 -- after the last aggregate assignment.
2944 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
2945 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
2947 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2950 -- In all other cases the counter is inserted after the last call to
2951 -- either [Deep_]Initialize or the type specific init proc.
2954 Find_Last_Init
(Count_Ins
, Body_Ins
);
2957 Insert_After
(Count_Ins
, Inc_Decl
);
2960 -- If the current declaration is the last in the list, the finalizer
2961 -- body needs to be inserted after the set counter statement for the
2962 -- current object declaration. This is complicated by the fact that
2963 -- the set counter statement may appear in abort deferred block. In
2964 -- that case, the proper insertion place is after the block.
2966 if No
(Finalizer_Insert_Nod
) then
2968 -- Insertion after an abort deffered block
2970 if Present
(Body_Ins
) then
2971 Finalizer_Insert_Nod
:= Body_Ins
;
2973 Finalizer_Insert_Nod
:= Inc_Decl
;
2977 -- Create the associated label with this object, generate:
2979 -- L<counter> : label;
2982 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2984 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2985 Label
:= Make_Label
(Loc
, Label_Id
);
2987 Prepend_To
(Finalizer_Decls
,
2988 Make_Implicit_Label_Declaration
(Loc
,
2989 Defining_Identifier
=> Entity
(Label_Id
),
2990 Label_Construct
=> Label
));
2992 -- Create the associated jump with this object, generate:
2994 -- when <counter> =>
2997 Prepend_To
(Jump_Alts
,
2998 Make_Case_Statement_Alternative
(Loc
,
2999 Discrete_Choices
=> New_List
(
3000 Make_Integer_Literal
(Loc
, Counter_Val
)),
3001 Statements
=> New_List
(
3002 Make_Goto_Statement
(Loc
,
3003 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3005 -- Insert the jump destination, generate:
3009 Append_To
(Finalizer_Stmts
, Label
);
3011 -- Processing for simple protected objects. Such objects require
3012 -- manual finalization of their lock managers.
3014 if Is_Protected
then
3015 Fin_Stmts
:= No_List
;
3017 if Is_Simple_Protected_Type
(Obj_Typ
) then
3018 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3020 if Present
(Fin_Call
) then
3021 Fin_Stmts
:= New_List
(Fin_Call
);
3024 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3025 if Is_Record_Type
(Obj_Typ
) then
3026 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3027 elsif Is_Array_Type
(Obj_Typ
) then
3028 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3034 -- System.Tasking.Protected_Objects.Finalize_Protection
3042 if Present
(Fin_Stmts
) then
3043 Append_To
(Finalizer_Stmts
,
3044 Make_Block_Statement
(Loc
,
3045 Handled_Statement_Sequence
=>
3046 Make_Handled_Sequence_Of_Statements
(Loc
,
3047 Statements
=> Fin_Stmts
,
3049 Exception_Handlers
=> New_List
(
3050 Make_Exception_Handler
(Loc
,
3051 Exception_Choices
=> New_List
(
3052 Make_Others_Choice
(Loc
)),
3054 Statements
=> New_List
(
3055 Make_Null_Statement
(Loc
)))))));
3058 -- Processing for regular controlled objects
3063 -- [Deep_]Finalize (Obj);
3066 -- when Id : others =>
3067 -- if not Raised then
3069 -- Save_Occurrence (E, Id);
3078 -- For CodePeer, the exception handlers normally generated here
3079 -- generate complex flowgraphs which result in capacity problems.
3080 -- Omitting these handlers for CodePeer is justified as follows:
3082 -- If a handler is dead, then omitting it is surely ok
3084 -- If a handler is live, then CodePeer should flag the
3085 -- potentially-exception-raising construct that causes it
3086 -- to be live. That is what we are interested in, not what
3087 -- happens after the exception is raised.
3089 if Exceptions_OK
and not CodePeer_Mode
then
3090 Fin_Stmts
:= New_List
(
3091 Make_Block_Statement
(Loc
,
3092 Handled_Statement_Sequence
=>
3093 Make_Handled_Sequence_Of_Statements
(Loc
,
3094 Statements
=> New_List
(Fin_Call
),
3096 Exception_Handlers
=> New_List
(
3097 Build_Exception_Handler
3098 (Finalizer_Data
, For_Package
)))));
3100 -- When exception handlers are prohibited, the finalization call
3101 -- appears unprotected. Any exception raised during finalization
3102 -- will bypass the circuitry which ensures the cleanup of all
3103 -- remaining objects.
3106 Fin_Stmts
:= New_List
(Fin_Call
);
3109 -- If we are dealing with a return object of a build-in-place
3110 -- function, generate the following cleanup statements:
3112 -- if BIPallocfrom > Secondary_Stack'Pos
3113 -- and then BIPfinalizationmaster /= null
3116 -- type Ptr_Typ is access Obj_Typ;
3117 -- for Ptr_Typ'Storage_Pool use
3118 -- Base_Pool (BIPfinalizationmaster.all).all;
3120 -- Free (Ptr_Typ (Temp));
3124 -- The generated code effectively detaches the temporary from the
3125 -- caller finalization master and deallocates the object.
3127 if Is_Return_Object
(Obj_Id
) then
3129 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3131 if Is_Build_In_Place_Function
(Func_Id
)
3132 and then Needs_BIP_Finalization_Master
(Func_Id
)
3134 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3139 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
3140 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3142 -- Temporaries created for the purpose of "exporting" a
3143 -- controlled transient out of an Expression_With_Actions (EWA)
3144 -- need guards. The following illustrates the usage of such
3147 -- Access_Typ : access [all] Obj_Typ;
3148 -- Temp : Access_Typ := null;
3149 -- <Counter> := ...;
3152 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3153 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3155 -- Temp := Ctrl_Trans'Unchecked_Access;
3158 -- The finalization machinery does not process EWA nodes as
3159 -- this may lead to premature finalization of expressions. Note
3160 -- that Temp is marked as being properly initialized regardless
3161 -- of whether the initialization of Ctrl_Trans succeeded. Since
3162 -- a failed initialization may leave Temp with a value of null,
3163 -- add a guard to handle this case:
3165 -- if Obj /= null then
3166 -- <object finalization statements>
3169 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3170 N_Object_Declaration
3172 Fin_Stmts
:= New_List
(
3173 Make_If_Statement
(Loc
,
3176 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3177 Right_Opnd
=> Make_Null
(Loc
)),
3178 Then_Statements
=> Fin_Stmts
));
3180 -- Return objects use a flag to aid in processing their
3181 -- potential finalization when the enclosing function fails
3182 -- to return properly. Generate:
3185 -- <object finalization statements>
3189 Fin_Stmts
:= New_List
(
3190 Make_If_Statement
(Loc
,
3195 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3197 Then_Statements
=> Fin_Stmts
));
3202 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3204 -- Since the declarations are examined in reverse, the state counter
3205 -- must be decremented in order to keep with the true position of
3208 Counter_Val
:= Counter_Val
- 1;
3209 end Process_Object_Declaration
;
3211 -------------------------------------
3212 -- Process_Tagged_Type_Declaration --
3213 -------------------------------------
3215 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3216 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3217 DT_Ptr
: constant Entity_Id
:=
3218 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3221 -- Ada.Tags.Unregister_Tag (<Typ>P);
3223 Append_To
(Tagged_Type_Stmts
,
3224 Make_Procedure_Call_Statement
(Loc
,
3226 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3227 Parameter_Associations
=> New_List
(
3228 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3229 end Process_Tagged_Type_Declaration
;
3231 -- Start of processing for Build_Finalizer
3236 -- Do not perform this expansion in SPARK mode because it is not
3239 if GNATprove_Mode
then
3243 -- Step 1: Extract all lists which may contain controlled objects or
3244 -- library-level tagged types.
3246 if For_Package_Spec
then
3247 Decls
:= Visible_Declarations
(Specification
(N
));
3248 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3250 -- Retrieve the package spec id
3252 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3254 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3255 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3258 -- Accept statement, block, entry body, package body, protected body,
3259 -- subprogram body or task body.
3262 Decls
:= Declarations
(N
);
3263 HSS
:= Handled_Statement_Sequence
(N
);
3265 if Present
(HSS
) then
3266 if Present
(Statements
(HSS
)) then
3267 Stmts
:= Statements
(HSS
);
3270 if Present
(At_End_Proc
(HSS
)) then
3271 Prev_At_End
:= At_End_Proc
(HSS
);
3275 -- Retrieve the package spec id for package bodies
3277 if For_Package_Body
then
3278 Spec_Id
:= Corresponding_Spec
(N
);
3282 -- Do not process nested packages since those are handled by the
3283 -- enclosing scope's finalizer. Do not process non-expanded package
3284 -- instantiations since those will be re-analyzed and re-expanded.
3288 (not Is_Library_Level_Entity
(Spec_Id
)
3290 -- Nested packages are considered to be library level entities,
3291 -- but do not need to be processed separately. True library level
3292 -- packages have a scope value of 1.
3294 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3295 or else (Is_Generic_Instance
(Spec_Id
)
3296 and then Package_Instantiation
(Spec_Id
) /= N
))
3301 -- Step 2: Object [pre]processing
3305 -- Preprocess the visible declarations now in order to obtain the
3306 -- correct number of controlled object by the time the private
3307 -- declarations are processed.
3309 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3311 -- From all the possible contexts, only package specifications may
3312 -- have private declarations.
3314 if For_Package_Spec
then
3315 Process_Declarations
3316 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3319 -- The current context may lack controlled objects, but require some
3320 -- other form of completion (task termination for instance). In such
3321 -- cases, the finalizer must be created and carry the additional
3324 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3328 -- The preprocessing has determined that the context has controlled
3329 -- objects or library-level tagged types.
3331 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3333 -- Private declarations are processed first in order to preserve
3334 -- possible dependencies between public and private objects.
3336 if For_Package_Spec
then
3337 Process_Declarations
(Priv_Decls
);
3340 Process_Declarations
(Decls
);
3346 -- Preprocess both declarations and statements
3348 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3349 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3351 -- At this point it is known that N has controlled objects. Ensure
3352 -- that N has a declarative list since the finalizer spec will be
3355 if Has_Ctrl_Objs
and then No
(Decls
) then
3356 Set_Declarations
(N
, New_List
);
3357 Decls
:= Declarations
(N
);
3358 Spec_Decls
:= Decls
;
3361 -- The current context may lack controlled objects, but require some
3362 -- other form of completion (task termination for instance). In such
3363 -- cases, the finalizer must be created and carry the additional
3366 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3370 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3371 Process_Declarations
(Stmts
);
3372 Process_Declarations
(Decls
);
3376 -- Step 3: Finalizer creation
3378 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3381 end Build_Finalizer
;
3383 --------------------------
3384 -- Build_Finalizer_Call --
3385 --------------------------
3387 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3388 Is_Prot_Body
: constant Boolean :=
3389 Nkind
(N
) = N_Subprogram_Body
3390 and then Is_Protected_Subprogram_Body
(N
);
3391 -- Determine whether N denotes the protected version of a subprogram
3392 -- which belongs to a protected type.
3394 Loc
: constant Source_Ptr
:= Sloc
(N
);
3398 -- Do not perform this expansion in SPARK mode because we do not create
3399 -- finalizers in the first place.
3401 if GNATprove_Mode
then
3405 -- The At_End handler should have been assimilated by the finalizer
3407 HSS
:= Handled_Statement_Sequence
(N
);
3408 pragma Assert
(No
(At_End_Proc
(HSS
)));
3410 -- If the construct to be cleaned up is a protected subprogram body, the
3411 -- finalizer call needs to be associated with the block which wraps the
3412 -- unprotected version of the subprogram. The following illustrates this
3415 -- procedure Prot_SubpP is
3416 -- procedure finalizer is
3418 -- Service_Entries (Prot_Obj);
3425 -- Prot_SubpN (Prot_Obj);
3431 if Is_Prot_Body
then
3432 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3434 -- An At_End handler and regular exception handlers cannot coexist in
3435 -- the same statement sequence. Wrap the original statements in a block.
3437 elsif Present
(Exception_Handlers
(HSS
)) then
3439 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3444 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3446 Set_Handled_Statement_Sequence
(N
,
3447 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3449 HSS
:= Handled_Statement_Sequence
(N
);
3450 Set_End_Label
(HSS
, End_Lab
);
3454 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3456 Analyze
(At_End_Proc
(HSS
));
3457 Expand_At_End_Handler
(HSS
, Empty
);
3458 end Build_Finalizer_Call
;
3460 ---------------------
3461 -- Build_Late_Proc --
3462 ---------------------
3464 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3466 for Final_Prim
in Name_Of
'Range loop
3467 if Name_Of
(Final_Prim
) = Nam
then
3470 (Prim
=> Final_Prim
,
3472 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3475 end Build_Late_Proc
;
3477 -------------------------------
3478 -- Build_Object_Declarations --
3479 -------------------------------
3481 procedure Build_Object_Declarations
3482 (Data
: out Finalization_Exception_Data
;
3485 For_Package
: Boolean := False)
3490 -- This variable captures an unused dummy internal entity, see the
3491 -- comment associated with its use.
3494 pragma Assert
(Decls
/= No_List
);
3496 -- Always set the proper location as it may be needed even when
3497 -- exception propagation is forbidden.
3501 if Restriction_Active
(No_Exception_Propagation
) then
3502 Data
.Abort_Id
:= Empty
;
3504 Data
.Raised_Id
:= Empty
;
3508 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3510 -- In certain scenarios, finalization can be triggered by an abort. If
3511 -- the finalization itself fails and raises an exception, the resulting
3512 -- Program_Error must be supressed and replaced by an abort signal. In
3513 -- order to detect this scenario, save the state of entry into the
3514 -- finalization code.
3516 -- This is not needed for library-level finalizers as they are called by
3517 -- the environment task and cannot be aborted.
3519 if not For_Package
then
3520 if Abort_Allowed
then
3521 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3524 -- Abort_Id : constant Boolean := <A_Expr>;
3527 Make_Object_Declaration
(Loc
,
3528 Defining_Identifier
=> Data
.Abort_Id
,
3529 Constant_Present
=> True,
3530 Object_Definition
=>
3531 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3533 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3535 -- Abort is not required
3538 -- Generate a dummy entity to ensure that the internal symbols are
3539 -- in sync when a unit is compiled with and without aborts.
3541 Dummy
:= Make_Temporary
(Loc
, 'A');
3542 Data
.Abort_Id
:= Empty
;
3545 -- Library-level finalizers
3548 Data
.Abort_Id
:= Empty
;
3551 if Exception_Extra_Info
then
3552 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3555 -- E_Id : Exception_Occurrence;
3558 Make_Object_Declaration
(Loc
,
3559 Defining_Identifier
=> Data
.E_Id
,
3560 Object_Definition
=>
3561 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3562 Set_No_Initialization
(Decl
);
3564 Append_To
(Decls
, Decl
);
3571 -- Raised_Id : Boolean := False;
3574 Make_Object_Declaration
(Loc
,
3575 Defining_Identifier
=> Data
.Raised_Id
,
3576 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3577 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3578 end Build_Object_Declarations
;
3580 ---------------------------
3581 -- Build_Raise_Statement --
3582 ---------------------------
3584 function Build_Raise_Statement
3585 (Data
: Finalization_Exception_Data
) return Node_Id
3591 -- Standard run-time use the specialized routine
3592 -- Raise_From_Controlled_Operation.
3594 if Exception_Extra_Info
3595 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3598 Make_Procedure_Call_Statement
(Data
.Loc
,
3601 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3602 Parameter_Associations
=>
3603 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3605 -- Restricted run-time: exception messages are not supported and hence
3606 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3611 Make_Raise_Program_Error
(Data
.Loc
,
3612 Reason
=> PE_Finalize_Raised_Exception
);
3617 -- Raised_Id and then not Abort_Id
3621 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3623 if Present
(Data
.Abort_Id
) then
3624 Expr
:= Make_And_Then
(Data
.Loc
,
3627 Make_Op_Not
(Data
.Loc
,
3628 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3633 -- if Raised_Id and then not Abort_Id then
3634 -- Raise_From_Controlled_Operation (E_Id);
3636 -- raise Program_Error; -- restricted runtime
3640 Make_If_Statement
(Data
.Loc
,
3642 Then_Statements
=> New_List
(Stmt
));
3643 end Build_Raise_Statement
;
3645 -----------------------------
3646 -- Build_Record_Deep_Procs --
3647 -----------------------------
3649 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3653 (Prim
=> Initialize_Case
,
3655 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3657 if not Is_Limited_View
(Typ
) then
3660 (Prim
=> Adjust_Case
,
3662 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3665 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3666 -- suppressed since these routine will not be used.
3668 if not Restriction_Active
(No_Finalization
) then
3671 (Prim
=> Finalize_Case
,
3673 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3675 -- Create TSS primitive Finalize_Address
3679 (Prim
=> Address_Case
,
3681 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3683 end Build_Record_Deep_Procs
;
3689 function Cleanup_Array
3692 Typ
: Entity_Id
) return List_Id
3694 Loc
: constant Source_Ptr
:= Sloc
(N
);
3695 Index_List
: constant List_Id
:= New_List
;
3697 function Free_Component
return List_Id
;
3698 -- Generate the code to finalize the task or protected subcomponents
3699 -- of a single component of the array.
3701 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3702 -- Generate a loop over one dimension of the array
3704 --------------------
3705 -- Free_Component --
3706 --------------------
3708 function Free_Component
return List_Id
is
3709 Stmts
: List_Id
:= New_List
;
3711 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3714 -- Component type is known to contain tasks or protected objects
3717 Make_Indexed_Component
(Loc
,
3718 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3719 Expressions
=> Index_List
);
3721 Set_Etype
(Tsk
, C_Typ
);
3723 if Is_Task_Type
(C_Typ
) then
3724 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3726 elsif Is_Simple_Protected_Type
(C_Typ
) then
3727 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3729 elsif Is_Record_Type
(C_Typ
) then
3730 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3732 elsif Is_Array_Type
(C_Typ
) then
3733 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3739 ------------------------
3740 -- Free_One_Dimension --
3741 ------------------------
3743 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3747 if Dim
> Number_Dimensions
(Typ
) then
3748 return Free_Component
;
3750 -- Here we generate the required loop
3753 Index
:= Make_Temporary
(Loc
, 'J');
3754 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3757 Make_Implicit_Loop_Statement
(N
,
3758 Identifier
=> Empty
,
3760 Make_Iteration_Scheme
(Loc
,
3761 Loop_Parameter_Specification
=>
3762 Make_Loop_Parameter_Specification
(Loc
,
3763 Defining_Identifier
=> Index
,
3764 Discrete_Subtype_Definition
=>
3765 Make_Attribute_Reference
(Loc
,
3766 Prefix
=> Duplicate_Subexpr
(Obj
),
3767 Attribute_Name
=> Name_Range
,
3768 Expressions
=> New_List
(
3769 Make_Integer_Literal
(Loc
, Dim
))))),
3770 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3772 end Free_One_Dimension
;
3774 -- Start of processing for Cleanup_Array
3777 return Free_One_Dimension
(1);
3780 --------------------
3781 -- Cleanup_Record --
3782 --------------------
3784 function Cleanup_Record
3787 Typ
: Entity_Id
) return List_Id
3789 Loc
: constant Source_Ptr
:= Sloc
(N
);
3792 Stmts
: constant List_Id
:= New_List
;
3793 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3796 if Has_Discriminants
(U_Typ
)
3797 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3798 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3801 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3803 -- For now, do not attempt to free a component that may appear in a
3804 -- variant, and instead issue a warning. Doing this "properly" would
3805 -- require building a case statement and would be quite a mess. Note
3806 -- that the RM only requires that free "work" for the case of a task
3807 -- access value, so already we go way beyond this in that we deal
3808 -- with the array case and non-discriminated record cases.
3811 ("task/protected object in variant record will not be freed??", N
);
3812 return New_List
(Make_Null_Statement
(Loc
));
3815 Comp
:= First_Component
(Typ
);
3816 while Present
(Comp
) loop
3817 if Has_Task
(Etype
(Comp
))
3818 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3821 Make_Selected_Component
(Loc
,
3822 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3823 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3824 Set_Etype
(Tsk
, Etype
(Comp
));
3826 if Is_Task_Type
(Etype
(Comp
)) then
3827 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3829 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3830 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3832 elsif Is_Record_Type
(Etype
(Comp
)) then
3834 -- Recurse, by generating the prefix of the argument to
3835 -- the eventual cleanup call.
3837 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3839 elsif Is_Array_Type
(Etype
(Comp
)) then
3840 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3844 Next_Component
(Comp
);
3850 ------------------------------
3851 -- Cleanup_Protected_Object --
3852 ------------------------------
3854 function Cleanup_Protected_Object
3856 Ref
: Node_Id
) return Node_Id
3858 Loc
: constant Source_Ptr
:= Sloc
(N
);
3861 -- For restricted run-time libraries (Ravenscar), tasks are
3862 -- non-terminating, and protected objects can only appear at library
3863 -- level, so we do not want finalization of protected objects.
3865 if Restricted_Profile
then
3870 Make_Procedure_Call_Statement
(Loc
,
3872 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3873 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3875 end Cleanup_Protected_Object
;
3881 function Cleanup_Task
3883 Ref
: Node_Id
) return Node_Id
3885 Loc
: constant Source_Ptr
:= Sloc
(N
);
3888 -- For restricted run-time libraries (Ravenscar), tasks are
3889 -- non-terminating and they can only appear at library level, so we do
3890 -- not want finalization of task objects.
3892 if Restricted_Profile
then
3897 Make_Procedure_Call_Statement
(Loc
,
3899 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3900 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3904 ------------------------------
3905 -- Check_Visibly_Controlled --
3906 ------------------------------
3908 procedure Check_Visibly_Controlled
3909 (Prim
: Final_Primitives
;
3911 E
: in out Entity_Id
;
3912 Cref
: in out Node_Id
)
3914 Parent_Type
: Entity_Id
;
3918 if Is_Derived_Type
(Typ
)
3919 and then Comes_From_Source
(E
)
3920 and then not Present
(Overridden_Operation
(E
))
3922 -- We know that the explicit operation on the type does not override
3923 -- the inherited operation of the parent, and that the derivation
3924 -- is from a private type that is not visibly controlled.
3926 Parent_Type
:= Etype
(Typ
);
3927 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3929 if Present
(Op
) then
3932 -- Wrap the object to be initialized into the proper
3933 -- unchecked conversion, to be compatible with the operation
3936 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3937 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3939 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3943 end Check_Visibly_Controlled
;
3949 function Convert_View
3952 Ind
: Pos
:= 1) return Node_Id
3954 Fent
: Entity_Id
:= First_Entity
(Proc
);
3959 for J
in 2 .. Ind
loop
3963 Ftyp
:= Etype
(Fent
);
3965 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3966 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3968 Atyp
:= Etype
(Arg
);
3971 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3972 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3975 and then Present
(Atyp
)
3976 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3977 and then Base_Type
(Underlying_Type
(Atyp
)) =
3978 Base_Type
(Underlying_Type
(Ftyp
))
3980 return Unchecked_Convert_To
(Ftyp
, Arg
);
3982 -- If the argument is already a conversion, as generated by
3983 -- Make_Init_Call, set the target type to the type of the formal
3984 -- directly, to avoid spurious typing problems.
3986 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3987 and then not Is_Class_Wide_Type
(Atyp
)
3989 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3990 Set_Etype
(Arg
, Ftyp
);
3993 -- Otherwise, introduce a conversion when the designated object
3994 -- has a type derived from the formal of the controlled routine.
3996 elsif Is_Private_Type
(Ftyp
)
3997 and then Present
(Atyp
)
3998 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4000 return Unchecked_Convert_To
(Ftyp
, Arg
);
4007 -------------------------------
4008 -- CW_Or_Has_Controlled_Part --
4009 -------------------------------
4011 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
4013 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
4014 end CW_Or_Has_Controlled_Part
;
4016 ------------------------
4017 -- Enclosing_Function --
4018 ------------------------
4020 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
4021 Func_Id
: Entity_Id
;
4025 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
4026 if Ekind
(Func_Id
) = E_Function
then
4030 Func_Id
:= Scope
(Func_Id
);
4034 end Enclosing_Function
;
4036 -------------------------------
4037 -- Establish_Transient_Scope --
4038 -------------------------------
4040 -- This procedure is called each time a transient block has to be inserted
4041 -- that is to say for each call to a function with unconstrained or tagged
4042 -- result. It creates a new scope on the stack scope in order to enclose
4043 -- all transient variables generated.
4045 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
4046 Loc
: constant Source_Ptr
:= Sloc
(N
);
4047 Iter_Loop
: Entity_Id
;
4048 Wrap_Node
: Node_Id
;
4051 -- Do not create a transient scope if we are already inside one
4053 for S
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4054 if Scope_Stack
.Table
(S
).Is_Transient
then
4056 Set_Uses_Sec_Stack
(Scope_Stack
.Table
(S
).Entity
);
4061 -- If we encounter Standard there are no enclosing transient scopes
4063 elsif Scope_Stack
.Table
(S
).Entity
= Standard_Standard
then
4068 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
4070 -- The context does not contain a node that requires a transient scope,
4073 if No
(Wrap_Node
) then
4076 -- If the node to wrap is an iteration_scheme, the expression is one of
4077 -- the bounds, and the expansion will make an explicit declaration for
4078 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
4079 -- transformations here. Same for an Ada 2012 iterator specification,
4080 -- where a block is created for the expression that build the container.
4082 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
4083 N_Iterator_Specification
)
4087 -- In formal verification mode, if the node to wrap is a pragma check,
4088 -- this node and enclosed expression are not expanded, so do not apply
4089 -- any transformations here.
4091 elsif GNATprove_Mode
4092 and then Nkind
(Wrap_Node
) = N_Pragma
4093 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
4097 -- Create a block entity to act as a transient scope. Note that when the
4098 -- node to be wrapped is an expression or a statement, a real physical
4099 -- block is constructed (see routines Wrap_Transient_Expression and
4100 -- Wrap_Transient_Statement) and inserted into the tree.
4103 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
4104 Set_Scope_Is_Transient
;
4106 -- The transient scope must also take care of the secondary stack
4110 Set_Uses_Sec_Stack
(Current_Scope
);
4111 Check_Restriction
(No_Secondary_Stack
, N
);
4113 -- The expansion of iterator loops generates references to objects
4114 -- in order to extract elements from a container:
4116 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4117 -- Obj : <object type> renames Ref.all.Element.all;
4119 -- These references are controlled and returned on the secondary
4120 -- stack. A new reference is created at each iteration of the loop
4121 -- and as a result it must be finalized and the space occupied by
4122 -- it on the secondary stack reclaimed at the end of the current
4125 -- When the context that requires a transient scope is a call to
4126 -- routine Reference, the node to be wrapped is the source object:
4128 -- for Obj of Container loop
4130 -- Routine Wrap_Transient_Declaration however does not generate a
4131 -- physical block as wrapping a declaration will kill it too ealy.
4132 -- To handle this peculiar case, mark the related iterator loop as
4133 -- requiring the secondary stack. This signals the finalization
4134 -- machinery to manage the secondary stack (see routine
4135 -- Process_Statements_For_Controlled_Objects).
4137 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
4139 if Present
(Iter_Loop
) then
4140 Set_Uses_Sec_Stack
(Iter_Loop
);
4144 Set_Etype
(Current_Scope
, Standard_Void_Type
);
4145 Set_Node_To_Be_Wrapped
(Wrap_Node
);
4147 if Debug_Flag_W
then
4148 Write_Str
(" <Transient>");
4152 end Establish_Transient_Scope
;
4154 ----------------------------
4155 -- Expand_Cleanup_Actions --
4156 ----------------------------
4158 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4159 Scop
: constant Entity_Id
:= Current_Scope
;
4161 Is_Asynchronous_Call
: constant Boolean :=
4162 Nkind
(N
) = N_Block_Statement
4163 and then Is_Asynchronous_Call_Block
(N
);
4164 Is_Master
: constant Boolean :=
4165 Nkind
(N
) /= N_Entry_Body
4166 and then Is_Task_Master
(N
);
4167 Is_Protected_Body
: constant Boolean :=
4168 Nkind
(N
) = N_Subprogram_Body
4169 and then Is_Protected_Subprogram_Body
(N
);
4170 Is_Task_Allocation
: constant Boolean :=
4171 Nkind
(N
) = N_Block_Statement
4172 and then Is_Task_Allocation_Block
(N
);
4173 Is_Task_Body
: constant Boolean :=
4174 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4175 Needs_Sec_Stack_Mark
: constant Boolean :=
4176 Uses_Sec_Stack
(Scop
)
4178 not Sec_Stack_Needed_For_Return
(Scop
);
4179 Needs_Custom_Cleanup
: constant Boolean :=
4180 Nkind
(N
) = N_Block_Statement
4181 and then Present
(Cleanup_Actions
(N
));
4183 Actions_Required
: constant Boolean :=
4184 Requires_Cleanup_Actions
(N
, True)
4185 or else Is_Asynchronous_Call
4187 or else Is_Protected_Body
4188 or else Is_Task_Allocation
4189 or else Is_Task_Body
4190 or else Needs_Sec_Stack_Mark
4191 or else Needs_Custom_Cleanup
;
4193 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
4197 procedure Wrap_HSS_In_Block
;
4198 -- Move HSS inside a new block along with the original exception
4199 -- handlers. Make the newly generated block the sole statement of HSS.
4201 -----------------------
4202 -- Wrap_HSS_In_Block --
4203 -----------------------
4205 procedure Wrap_HSS_In_Block
is
4207 Block_Id
: Entity_Id
;
4211 -- Preserve end label to provide proper cross-reference information
4213 End_Lab
:= End_Label
(HSS
);
4215 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
4217 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4218 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
4219 Set_Etype
(Block_Id
, Standard_Void_Type
);
4220 Set_Block_Node
(Block_Id
, Identifier
(Block
));
4222 -- Signal the finalization machinery that this particular block
4223 -- contains the original context.
4225 Set_Is_Finalization_Wrapper
(Block
);
4227 Set_Handled_Statement_Sequence
(N
,
4228 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
4229 HSS
:= Handled_Statement_Sequence
(N
);
4231 Set_First_Real_Statement
(HSS
, Block
);
4232 Set_End_Label
(HSS
, End_Lab
);
4234 -- Comment needed here, see RH for 1.306 ???
4236 if Nkind
(N
) = N_Subprogram_Body
then
4237 Set_Has_Nested_Block_With_Handler
(Scop
);
4239 end Wrap_HSS_In_Block
;
4241 -- Start of processing for Expand_Cleanup_Actions
4244 -- The current construct does not need any form of servicing
4246 if not Actions_Required
then
4249 -- If the current node is a rewritten task body and the descriptors have
4250 -- not been delayed (due to some nested instantiations), do not generate
4251 -- redundant cleanup actions.
4254 and then Nkind
(N
) = N_Subprogram_Body
4255 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4260 if Needs_Custom_Cleanup
then
4261 Cln
:= Cleanup_Actions
(N
);
4267 Decls
: List_Id
:= Declarations
(N
);
4269 Mark
: Entity_Id
:= Empty
;
4270 New_Decls
: List_Id
;
4274 -- If we are generating expanded code for debugging purposes, use the
4275 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4276 -- be updated subsequently to reference the proper line in .dg files.
4277 -- If we are not debugging generated code, use No_Location instead,
4278 -- so that no debug information is generated for the cleanup code.
4279 -- This makes the behavior of the NEXT command in GDB monotonic, and
4280 -- makes the placement of breakpoints more accurate.
4282 if Debug_Generated_Code
then
4288 -- Set polling off. The finalization and cleanup code is executed
4289 -- with aborts deferred.
4291 Old_Poll
:= Polling_Required
;
4292 Polling_Required
:= False;
4294 -- A task activation call has already been built for a task
4295 -- allocation block.
4297 if not Is_Task_Allocation
then
4298 Build_Task_Activation_Call
(N
);
4302 Establish_Task_Master
(N
);
4305 New_Decls
:= New_List
;
4307 -- If secondary stack is in use, generate:
4309 -- Mnn : constant Mark_Id := SS_Mark;
4311 if Needs_Sec_Stack_Mark
then
4312 Mark
:= Make_Temporary
(Loc
, 'M');
4314 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4315 Set_Uses_Sec_Stack
(Scop
, False);
4318 -- If exception handlers are present, wrap the sequence of statements
4319 -- in a block since it is not possible to have exception handlers and
4320 -- an At_End handler in the same construct.
4322 if Present
(Exception_Handlers
(HSS
)) then
4325 -- Ensure that the First_Real_Statement field is set
4327 elsif No
(First_Real_Statement
(HSS
)) then
4328 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4331 -- Do not move the Activation_Chain declaration in the context of
4332 -- task allocation blocks. Task allocation blocks use _chain in their
4333 -- cleanup handlers and gigi complains if it is declared in the
4334 -- sequence of statements of the scope that declares the handler.
4336 if Is_Task_Allocation
then
4338 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4342 Decl
:= First
(Decls
);
4343 while Nkind
(Decl
) /= N_Object_Declaration
4344 or else Defining_Identifier
(Decl
) /= Chain
4348 -- A task allocation block should always include a _chain
4351 pragma Assert
(Present
(Decl
));
4355 Prepend_To
(New_Decls
, Decl
);
4359 -- Ensure the presence of a declaration list in order to successfully
4360 -- append all original statements to it.
4363 Set_Declarations
(N
, New_List
);
4364 Decls
:= Declarations
(N
);
4367 -- Move the declarations into the sequence of statements in order to
4368 -- have them protected by the At_End handler. It may seem weird to
4369 -- put declarations in the sequence of statement but in fact nothing
4370 -- forbids that at the tree level.
4372 Append_List_To
(Decls
, Statements
(HSS
));
4373 Set_Statements
(HSS
, Decls
);
4375 -- Reset the Sloc of the handled statement sequence to properly
4376 -- reflect the new initial "statement" in the sequence.
4378 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4380 -- The declarations of finalizer spec and auxiliary variables replace
4381 -- the old declarations that have been moved inward.
4383 Set_Declarations
(N
, New_Decls
);
4384 Analyze_Declarations
(New_Decls
);
4386 -- Generate finalization calls for all controlled objects appearing
4387 -- in the statements of N. Add context specific cleanup for various
4392 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4394 Top_Decls
=> New_Decls
,
4395 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4399 if Present
(Fin_Id
) then
4400 Build_Finalizer_Call
(N
, Fin_Id
);
4403 -- Restore saved polling mode
4405 Polling_Required
:= Old_Poll
;
4407 end Expand_Cleanup_Actions
;
4409 ---------------------------
4410 -- Expand_N_Package_Body --
4411 ---------------------------
4413 -- Add call to Activate_Tasks if body is an activator (actual processing
4414 -- is in chapter 9).
4416 -- Generate subprogram descriptor for elaboration routine
4418 -- Encode entity names in package body
4420 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4421 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
4424 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
4427 -- The package body is Ghost when the corresponding spec is Ghost. Set
4428 -- the mode now to ensure that any nodes generated during expansion are
4429 -- properly marked as Ghost.
4431 Set_Ghost_Mode
(N
, Spec_Id
);
4433 -- This is done only for non-generic packages
4435 if Ekind
(Spec_Id
) = E_Package
then
4436 Push_Scope
(Corresponding_Spec
(N
));
4438 -- Build dispatch tables of library level tagged types
4440 if Tagged_Type_Expansion
4441 and then Is_Library_Level_Entity
(Spec_Id
)
4443 Build_Static_Dispatch_Tables
(N
);
4446 Build_Task_Activation_Call
(N
);
4448 -- When the package is subject to pragma Initial_Condition, the
4449 -- assertion expression must be verified at the end of the body
4452 if Present
(Get_Pragma
(Spec_Id
, Pragma_Initial_Condition
)) then
4453 Expand_Pragma_Initial_Condition
(N
);
4459 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
4460 Set_In_Package_Body
(Spec_Id
, False);
4462 -- Set to encode entity names in package body before gigi is called
4464 Qualify_Entity_Names
(N
);
4466 if Ekind
(Spec_Id
) /= E_Generic_Package
then
4469 Clean_Stmts
=> No_List
,
4471 Top_Decls
=> No_List
,
4472 Defer_Abort
=> False,
4475 if Present
(Fin_Id
) then
4477 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4480 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4481 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4484 Set_Finalizer
(Body_Ent
, Fin_Id
);
4489 Ghost_Mode
:= Save_Ghost_Mode
;
4490 end Expand_N_Package_Body
;
4492 ----------------------------------
4493 -- Expand_N_Package_Declaration --
4494 ----------------------------------
4496 -- Add call to Activate_Tasks if there are tasks declared and the package
4497 -- has no body. Note that in Ada 83 this may result in premature activation
4498 -- of some tasks, given that we cannot tell whether a body will eventually
4501 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4502 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4503 Spec
: constant Node_Id
:= Specification
(N
);
4507 No_Body
: Boolean := False;
4508 -- True in the case of a package declaration that is a compilation
4509 -- unit and for which no associated body will be compiled in this
4513 -- Case of a package declaration other than a compilation unit
4515 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4518 -- Case of a compilation unit that does not require a body
4520 elsif not Body_Required
(Parent
(N
))
4521 and then not Unit_Requires_Body
(Id
)
4525 -- Special case of generating calling stubs for a remote call interface
4526 -- package: even though the package declaration requires one, the body
4527 -- won't be processed in this compilation (so any stubs for RACWs
4528 -- declared in the package must be generated here, along with the spec).
4530 elsif Parent
(N
) = Cunit
(Main_Unit
)
4531 and then Is_Remote_Call_Interface
(Id
)
4532 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4537 -- For a nested instance, delay processing until freeze point
4539 if Has_Delayed_Freeze
(Id
)
4540 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4545 -- For a package declaration that implies no associated body, generate
4546 -- task activation call and RACW supporting bodies now (since we won't
4547 -- have a specific separate compilation unit for that).
4552 -- Generate RACW subprogram bodies
4554 if Has_RACW
(Id
) then
4555 Decls
:= Private_Declarations
(Spec
);
4558 Decls
:= Visible_Declarations
(Spec
);
4563 Set_Visible_Declarations
(Spec
, Decls
);
4566 Append_RACW_Bodies
(Decls
, Id
);
4567 Analyze_List
(Decls
);
4570 -- Generate task activation call as last step of elaboration
4572 if Present
(Activation_Chain_Entity
(N
)) then
4573 Build_Task_Activation_Call
(N
);
4576 -- When the package is subject to pragma Initial_Condition and lacks
4577 -- a body, the assertion expression must be verified at the end of
4578 -- the visible declarations. Otherwise the check is performed at the
4579 -- end of the body statements (see Expand_N_Package_Body).
4581 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4582 Expand_Pragma_Initial_Condition
(N
);
4588 -- Build dispatch tables of library level tagged types
4590 if Tagged_Type_Expansion
4591 and then (Is_Compilation_Unit
(Id
)
4592 or else (Is_Generic_Instance
(Id
)
4593 and then Is_Library_Level_Entity
(Id
)))
4595 Build_Static_Dispatch_Tables
(N
);
4598 -- Note: it is not necessary to worry about generating a subprogram
4599 -- descriptor, since the only way to get exception handlers into a
4600 -- package spec is to include instantiations, and that would cause
4601 -- generation of subprogram descriptors to be delayed in any case.
4603 -- Set to encode entity names in package spec before gigi is called
4605 Qualify_Entity_Names
(N
);
4607 if Ekind
(Id
) /= E_Generic_Package
then
4610 Clean_Stmts
=> No_List
,
4612 Top_Decls
=> No_List
,
4613 Defer_Abort
=> False,
4616 Set_Finalizer
(Id
, Fin_Id
);
4618 end Expand_N_Package_Declaration
;
4620 -----------------------------
4621 -- Find_Node_To_Be_Wrapped --
4622 -----------------------------
4624 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4626 The_Parent
: Node_Id
;
4632 case Nkind
(The_Parent
) is
4634 -- Simple statement can be wrapped
4639 -- Usually assignments are good candidate for wrapping except
4640 -- when they have been generated as part of a controlled aggregate
4641 -- where the wrapping should take place more globally. Note that
4642 -- No_Ctrl_Actions may be set also for non-controlled assignements
4643 -- in order to disable the use of dispatching _assign, so we need
4644 -- to test explicitly for a controlled type here.
4646 when N_Assignment_Statement
=>
4647 if No_Ctrl_Actions
(The_Parent
)
4648 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4655 -- An entry call statement is a special case if it occurs in the
4656 -- context of a Timed_Entry_Call. In this case we wrap the entire
4657 -- timed entry call.
4659 when N_Entry_Call_Statement |
4660 N_Procedure_Call_Statement
=>
4661 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4662 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4664 N_Conditional_Entry_Call
)
4666 return Parent
(Parent
(The_Parent
));
4671 -- Object declarations are also a boundary for the transient scope
4672 -- even if they are not really wrapped. For further details, see
4673 -- Wrap_Transient_Declaration.
4675 when N_Object_Declaration |
4676 N_Object_Renaming_Declaration |
4677 N_Subtype_Declaration
=>
4680 -- The expression itself is to be wrapped if its parent is a
4681 -- compound statement or any other statement where the expression
4682 -- is known to be scalar.
4684 when N_Accept_Alternative |
4685 N_Attribute_Definition_Clause |
4688 N_Delay_Alternative |
4689 N_Delay_Until_Statement |
4690 N_Delay_Relative_Statement |
4691 N_Discriminant_Association |
4693 N_Entry_Body_Formal_Part |
4696 N_Iteration_Scheme |
4697 N_Terminate_Alternative
=>
4698 pragma Assert
(Present
(P
));
4701 when N_Attribute_Reference
=>
4703 if Is_Procedure_Attribute_Name
4704 (Attribute_Name
(The_Parent
))
4709 -- A raise statement can be wrapped. This will arise when the
4710 -- expression in a raise_with_expression uses the secondary
4711 -- stack, for example.
4713 when N_Raise_Statement
=>
4716 -- If the expression is within the iteration scheme of a loop,
4717 -- we must create a declaration for it, followed by an assignment
4718 -- in order to have a usable statement to wrap.
4720 when N_Loop_Parameter_Specification
=>
4721 return Parent
(The_Parent
);
4723 -- The following nodes contains "dummy calls" which don't need to
4726 when N_Parameter_Specification |
4727 N_Discriminant_Specification |
4728 N_Component_Declaration
=>
4731 -- The return statement is not to be wrapped when the function
4732 -- itself needs wrapping at the outer-level
4734 when N_Simple_Return_Statement
=>
4736 Applies_To
: constant Entity_Id
:=
4738 (Return_Statement_Entity
(The_Parent
));
4739 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4741 if Requires_Transient_Scope
(Return_Type
) then
4748 -- If we leave a scope without having been able to find a node to
4749 -- wrap, something is going wrong but this can happen in error
4750 -- situation that are not detected yet (such as a dynamic string
4751 -- in a pragma export)
4753 when N_Subprogram_Body |
4754 N_Package_Declaration |
4756 N_Block_Statement
=>
4759 -- Otherwise continue the search
4766 The_Parent
:= Parent
(P
);
4768 end Find_Node_To_Be_Wrapped
;
4770 ----------------------------------
4771 -- Has_New_Controlled_Component --
4772 ----------------------------------
4774 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4778 if not Is_Tagged_Type
(E
) then
4779 return Has_Controlled_Component
(E
);
4780 elsif not Is_Derived_Type
(E
) then
4781 return Has_Controlled_Component
(E
);
4784 Comp
:= First_Component
(E
);
4785 while Present
(Comp
) loop
4786 if Chars
(Comp
) = Name_uParent
then
4789 elsif Scope
(Original_Record_Component
(Comp
)) = E
4790 and then Needs_Finalization
(Etype
(Comp
))
4795 Next_Component
(Comp
);
4799 end Has_New_Controlled_Component
;
4801 ---------------------------------
4802 -- Has_Simple_Protected_Object --
4803 ---------------------------------
4805 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4807 if Has_Task
(T
) then
4810 elsif Is_Simple_Protected_Type
(T
) then
4813 elsif Is_Array_Type
(T
) then
4814 return Has_Simple_Protected_Object
(Component_Type
(T
));
4816 elsif Is_Record_Type
(T
) then
4821 Comp
:= First_Component
(T
);
4822 while Present
(Comp
) loop
4823 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4827 Next_Component
(Comp
);
4836 end Has_Simple_Protected_Object
;
4838 ------------------------------------
4839 -- Insert_Actions_In_Scope_Around --
4840 ------------------------------------
4842 procedure Insert_Actions_In_Scope_Around
4845 Manage_SS
: Boolean)
4847 Act_Before
: constant List_Id
:=
4848 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4849 Act_After
: constant List_Id
:=
4850 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4851 Act_Cleanup
: constant List_Id
:=
4852 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4853 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4854 -- Last), but this was incorrect as Process_Transient_Object may
4855 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4857 procedure Process_Transient_Objects
4858 (First_Object
: Node_Id
;
4859 Last_Object
: Node_Id
;
4860 Related_Node
: Node_Id
);
4861 -- First_Object and Last_Object define a list which contains potential
4862 -- controlled transient objects. Finalization flags are inserted before
4863 -- First_Object and finalization calls are inserted after Last_Object.
4864 -- Related_Node is the node for which transient objects have been
4867 -------------------------------
4868 -- Process_Transient_Objects --
4869 -------------------------------
4871 procedure Process_Transient_Objects
4872 (First_Object
: Node_Id
;
4873 Last_Object
: Node_Id
;
4874 Related_Node
: Node_Id
)
4876 Must_Hook
: Boolean := False;
4877 -- Flag denoting whether the context requires transient variable
4878 -- export to the outer finalizer.
4880 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4881 -- Determine whether an arbitrary node denotes a subprogram call
4883 procedure Detect_Subprogram_Call
is
4884 new Traverse_Proc
(Is_Subprogram_Call
);
4886 ------------------------
4887 -- Is_Subprogram_Call --
4888 ------------------------
4890 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4892 -- A regular procedure or function call
4894 if Nkind
(N
) in N_Subprogram_Call
then
4900 -- Heavy expansion may relocate function calls outside the related
4901 -- node. Inspect the original node to detect the initial placement
4904 elsif Original_Node
(N
) /= N
then
4905 Detect_Subprogram_Call
(Original_Node
(N
));
4913 -- Generalized indexing always involves a function call
4915 elsif Nkind
(N
) = N_Indexed_Component
4916 and then Present
(Generalized_Indexing
(N
))
4926 end Is_Subprogram_Call
;
4930 Exceptions_OK
: constant Boolean :=
4931 not Restriction_Active
(No_Exception_Propagation
);
4933 Built
: Boolean := False;
4934 Blk_Decl
: Node_Id
:= Empty
;
4935 Blk_Decls
: List_Id
:= No_List
;
4937 Blk_Stmts
: List_Id
;
4938 Desig_Typ
: Entity_Id
;
4940 Fin_Data
: Finalization_Exception_Data
;
4941 Fin_Stmts
: List_Id
;
4942 Hook_Clr
: Node_Id
:= Empty
;
4943 Hook_Id
: Entity_Id
;
4945 Init_Expr
: Node_Id
;
4950 Obj_Typ
: Entity_Id
;
4951 Ptr_Typ
: Entity_Id
;
4953 -- Start of processing for Process_Transient_Objects
4956 -- The expansion performed by this routine is as follows:
4958 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
4959 -- Hook_1 : Ptr_Typ_1 := null;
4960 -- Ctrl_Trans_Obj_1 : ...;
4961 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
4963 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
4964 -- Hook_N : Ptr_Typ_N := null;
4965 -- Ctrl_Trans_Obj_N : ...;
4966 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
4969 -- Abrt : constant Boolean := ...;
4970 -- Ex : Exception_Occurrence;
4971 -- Raised : Boolean := False;
4978 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
4982 -- if not Raised then
4984 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
4989 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
4993 -- if not Raised then
4995 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
4998 -- if Raised and not Abrt then
4999 -- Raise_From_Controlled_Operation (Ex);
5002 -- Abort_Undefer_Direct;
5005 -- Recognize a scenario where the transient context is an object
5006 -- declaration initialized by a build-in-place function call:
5008 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5010 -- The rough expansion of the above is:
5012 -- Temp : ... := Ctrl_Func_Call;
5014 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5016 -- The finalization of any controlled transient must happen after
5017 -- the build-in-place function call is executed.
5019 if Nkind
(N
) = N_Object_Declaration
5020 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5023 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5025 -- Search the context for at least one subprogram call. If found, the
5026 -- machinery exports all transient objects to the enclosing finalizer
5027 -- due to the possibility of abnormal call termination.
5030 Detect_Subprogram_Call
(N
);
5031 Blk_Ins
:= Last_Object
;
5035 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5038 -- Examine all objects in the list First_Object .. Last_Object
5040 Obj_Decl
:= First_Object
;
5041 while Present
(Obj_Decl
) loop
5042 if Nkind
(Obj_Decl
) = N_Object_Declaration
5043 and then Analyzed
(Obj_Decl
)
5044 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5046 -- Do not process the node to be wrapped since it will be
5047 -- handled by the enclosing finalizer.
5049 and then Obj_Decl
/= Related_Node
5051 Loc
:= Sloc
(Obj_Decl
);
5052 Obj_Id
:= Defining_Identifier
(Obj_Decl
);
5053 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
5054 Desig_Typ
:= Obj_Typ
;
5056 Set_Is_Processed_Transient
(Obj_Id
);
5058 -- Handle access types
5060 if Is_Access_Type
(Desig_Typ
) then
5061 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
5064 -- Transient objects associated with subprogram calls need
5065 -- extra processing. These objects are usually created right
5066 -- before the call and finalized immediately after the call.
5067 -- If an exception occurs during the call, the clean up code
5068 -- is skipped due to the sudden change in control and the
5069 -- transient is never finalized.
5071 -- To handle this case, such variables are "exported" to the
5072 -- enclosing sequence of statements where their corresponding
5073 -- "hooks" are picked up by the finalization machinery.
5077 -- Create an access type which provides a reference to the
5078 -- transient object. Generate:
5079 -- type Ptr_Typ is access [all] Desig_Typ;
5081 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
5083 Insert_Action
(Obj_Decl
,
5084 Make_Full_Type_Declaration
(Loc
,
5085 Defining_Identifier
=> Ptr_Typ
,
5087 Make_Access_To_Object_Definition
(Loc
,
5089 Ekind
(Obj_Typ
) = E_General_Access_Type
,
5090 Subtype_Indication
=>
5091 New_Occurrence_Of
(Desig_Typ
, Loc
))));
5093 -- Create a temporary which acts as a hook to the transient
5094 -- object. Generate:
5095 -- Hook : Ptr_Typ := null;
5097 Hook_Id
:= Make_Temporary
(Loc
, 'T');
5099 Insert_Action
(Obj_Decl
,
5100 Make_Object_Declaration
(Loc
,
5101 Defining_Identifier
=> Hook_Id
,
5102 Object_Definition
=>
5103 New_Occurrence_Of
(Ptr_Typ
, Loc
)));
5105 -- Mark the temporary as a hook. This signals the machinery
5106 -- in Build_Finalizer to recognize this special case.
5108 Set_Status_Flag_Or_Transient_Decl
(Hook_Id
, Obj_Decl
);
5110 -- Hook the transient object to the temporary. Generate:
5111 -- Hook := Ptr_Typ (Obj_Id);
5113 -- Hook := Obj_Id'Unrestricted_Access;
5115 if Is_Access_Type
(Obj_Typ
) then
5117 Convert_To
(Ptr_Typ
, New_Occurrence_Of
(Obj_Id
, Loc
));
5121 Make_Attribute_Reference
(Loc
,
5122 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
5123 Attribute_Name
=> Name_Unrestricted_Access
);
5126 -- When the transient object is initialized by an aggregate,
5127 -- the hook must capture the object after the last component
5128 -- assignment takes place. Only then is the object fully
5131 if Ekind
(Obj_Id
) = E_Variable
5132 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
5134 Hook_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
5136 -- Otherwise the hook seizes the related object immediately
5139 Hook_Ins
:= Obj_Decl
;
5142 Insert_After_And_Analyze
(Hook_Ins
,
5143 Make_Assignment_Statement
(Loc
,
5144 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
5145 Expression
=> Init_Expr
));
5147 -- The transient object is about to be finalized by the
5148 -- clean up code following the subprogram call. In order
5149 -- to avoid double finalization, clear the hook.
5155 Make_Assignment_Statement
(Loc
,
5156 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
5157 Expression
=> Make_Null
(Loc
));
5160 -- Before generating the clean up code for the first transient
5161 -- object, create a wrapper block which houses all hook clear
5162 -- statements and finalization calls. This wrapper is needed by
5167 Blk_Stmts
:= New_List
;
5169 -- Create the declarations of all entities that participate
5170 -- in exception detection and propagation.
5172 if Exceptions_OK
then
5173 Blk_Decls
:= New_List
;
5176 -- Abrt : constant Boolean := ...;
5177 -- Ex : Exception_Occurrence;
5178 -- Raised : Boolean := False;
5180 Build_Object_Declarations
(Fin_Data
, Blk_Decls
, Loc
);
5183 -- if Raised and then not Abrt then
5184 -- Raise_From_Controlled_Operation (Ex);
5187 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Fin_Data
));
5191 Make_Block_Statement
(Loc
,
5192 Declarations
=> Blk_Decls
,
5193 Handled_Statement_Sequence
=>
5194 Make_Handled_Sequence_Of_Statements
(Loc
,
5195 Statements
=> Blk_Stmts
));
5199 -- [Deep_]Finalize (Obj_Ref);
5201 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
5203 if Is_Access_Type
(Obj_Typ
) then
5204 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
5205 Set_Etype
(Obj_Ref
, Desig_Typ
);
5209 Make_Final_Call
(Obj_Ref
=> Obj_Ref
, Typ
=> Desig_Typ
);
5211 -- When exception propagation is enabled wrap the hook clear
5212 -- statement and the finalization call into a block to catch
5213 -- potential exceptions raised during finalization. Generate:
5217 -- [Deep_]Finalize (Obj_Ref);
5221 -- if not Raised then
5224 -- (Enn, Get_Current_Excep.all.all);
5228 if Exceptions_OK
then
5229 Fin_Stmts
:= New_List
;
5231 if Present
(Hook_Clr
) then
5232 Append_To
(Fin_Stmts
, Hook_Clr
);
5235 Append_To
(Fin_Stmts
, Fin_Call
);
5237 Prepend_To
(Blk_Stmts
,
5238 Make_Block_Statement
(Loc
,
5239 Handled_Statement_Sequence
=>
5240 Make_Handled_Sequence_Of_Statements
(Loc
,
5241 Statements
=> Fin_Stmts
,
5242 Exception_Handlers
=> New_List
(
5243 Build_Exception_Handler
(Fin_Data
)))));
5245 -- Otherwise generate:
5247 -- [Deep_]Finalize (Obj_Ref);
5250 Prepend_To
(Blk_Stmts
, Fin_Call
);
5252 if Present
(Hook_Clr
) then
5253 Prepend_To
(Blk_Stmts
, Hook_Clr
);
5258 -- Terminate the scan after the last object has been processed to
5259 -- avoid touching unrelated code.
5261 if Obj_Decl
= Last_Object
then
5268 if Present
(Blk_Decl
) then
5270 -- Note that the abort defer / undefer pair does not require an
5271 -- extra block because each finalization exception is caught in
5272 -- its corresponding finalization block. As a result, the call to
5273 -- Abort_Defer always takes place.
5275 if Abort_Allowed
then
5276 Prepend_To
(Blk_Stmts
,
5277 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5279 Append_To
(Blk_Stmts
,
5280 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5283 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5285 end Process_Transient_Objects
;
5289 Loc
: constant Source_Ptr
:= Sloc
(N
);
5290 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5291 First_Obj
: Node_Id
;
5293 Mark_Id
: Entity_Id
;
5296 -- Start of processing for Insert_Actions_In_Scope_Around
5299 if No
(Act_Before
) and then No
(Act_After
) and then No
(Act_Cleanup
) then
5303 -- If the node to be wrapped is the trigger of an asynchronous select,
5304 -- it is not part of a statement list. The actions must be inserted
5305 -- before the select itself, which is part of some list of statements.
5306 -- Note that the triggering alternative includes the triggering
5307 -- statement and an optional statement list. If the node to be
5308 -- wrapped is part of that list, the normal insertion applies.
5310 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5311 and then not Is_List_Member
(Node_To_Wrap
)
5313 Target
:= Parent
(Parent
(Node_To_Wrap
));
5318 First_Obj
:= Target
;
5321 -- Add all actions associated with a transient scope into the main tree.
5322 -- There are several scenarios here:
5324 -- +--- Before ----+ +----- After ---+
5325 -- 1) First_Obj ....... Target ........ Last_Obj
5327 -- 2) First_Obj ....... Target
5329 -- 3) Target ........ Last_Obj
5331 -- Flag declarations are inserted before the first object
5333 if Present
(Act_Before
) then
5334 First_Obj
:= First
(Act_Before
);
5335 Insert_List_Before
(Target
, Act_Before
);
5338 -- Finalization calls are inserted after the last object
5340 if Present
(Act_After
) then
5341 Last_Obj
:= Last
(Act_After
);
5342 Insert_List_After
(Target
, Act_After
);
5345 -- Mark and release the secondary stack when the context warrants it
5348 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5351 -- Mnn : constant Mark_Id := SS_Mark;
5353 Insert_Before_And_Analyze
5354 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5357 -- SS_Release (Mnn);
5359 Insert_After_And_Analyze
5360 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5363 -- Check for transient controlled objects associated with Target and
5364 -- generate the appropriate finalization actions for them.
5366 Process_Transient_Objects
5367 (First_Object
=> First_Obj
,
5368 Last_Object
=> Last_Obj
,
5369 Related_Node
=> Target
);
5371 -- Reset the action lists
5374 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5376 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5380 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5382 end Insert_Actions_In_Scope_Around
;
5384 ------------------------------
5385 -- Is_Simple_Protected_Type --
5386 ------------------------------
5388 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5391 Is_Protected_Type
(T
)
5392 and then not Uses_Lock_Free
(T
)
5393 and then not Has_Entries
(T
)
5394 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5395 end Is_Simple_Protected_Type
;
5397 -----------------------
5398 -- Make_Adjust_Call --
5399 -----------------------
5401 function Make_Adjust_Call
5404 Skip_Self
: Boolean := False) return Node_Id
5406 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5407 Adj_Id
: Entity_Id
:= Empty
;
5408 Ref
: Node_Id
:= Obj_Ref
;
5412 -- Recover the proper type which contains Deep_Adjust
5414 if Is_Class_Wide_Type
(Typ
) then
5415 Utyp
:= Root_Type
(Typ
);
5420 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5421 Set_Assignment_OK
(Ref
);
5423 -- Deal with untagged derivation of private views
5425 if Is_Untagged_Derivation
(Typ
) then
5426 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5427 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5428 Set_Assignment_OK
(Ref
);
5431 -- When dealing with the completion of a private type, use the base
5434 if Utyp
/= Base_Type
(Utyp
) then
5435 pragma Assert
(Is_Private_Type
(Typ
));
5437 Utyp
:= Base_Type
(Utyp
);
5438 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5442 if Has_Controlled_Component
(Utyp
) then
5443 if Is_Tagged_Type
(Utyp
) then
5444 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5446 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5450 -- Class-wide types, interfaces and types with controlled components
5452 elsif Is_Class_Wide_Type
(Typ
)
5453 or else Is_Interface
(Typ
)
5454 or else Has_Controlled_Component
(Utyp
)
5456 if Is_Tagged_Type
(Utyp
) then
5457 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5459 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5462 -- Derivations from [Limited_]Controlled
5464 elsif Is_Controlled
(Utyp
) then
5465 if Has_Controlled_Component
(Utyp
) then
5466 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5468 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5473 elsif Is_Tagged_Type
(Utyp
) then
5474 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5477 raise Program_Error
;
5480 if Present
(Adj_Id
) then
5482 -- If the object is unanalyzed, set its expected type for use in
5483 -- Convert_View in case an additional conversion is needed.
5486 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5488 Set_Etype
(Ref
, Typ
);
5491 -- The object reference may need another conversion depending on the
5492 -- type of the formal and that of the actual.
5494 if not Is_Class_Wide_Type
(Typ
) then
5495 Ref
:= Convert_View
(Adj_Id
, Ref
);
5501 Param
=> New_Copy_Tree
(Ref
),
5502 Skip_Self
=> Skip_Self
);
5506 end Make_Adjust_Call
;
5508 ----------------------
5509 -- Make_Detach_Call --
5510 ----------------------
5512 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5513 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5517 Make_Procedure_Call_Statement
(Loc
,
5519 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5520 Parameter_Associations
=> New_List
(
5521 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5522 end Make_Detach_Call
;
5530 Proc_Id
: Entity_Id
;
5532 Skip_Self
: Boolean := False) return Node_Id
5534 Params
: constant List_Id
:= New_List
(Param
);
5537 -- Do not apply the controlled action to the object itself by signaling
5538 -- the related routine to avoid self.
5541 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5545 Make_Procedure_Call_Statement
(Loc
,
5546 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5547 Parameter_Associations
=> Params
);
5550 --------------------------
5551 -- Make_Deep_Array_Body --
5552 --------------------------
5554 function Make_Deep_Array_Body
5555 (Prim
: Final_Primitives
;
5556 Typ
: Entity_Id
) return List_Id
5558 function Build_Adjust_Or_Finalize_Statements
5559 (Typ
: Entity_Id
) return List_Id
;
5560 -- Create the statements necessary to adjust or finalize an array of
5561 -- controlled elements. Generate:
5564 -- Abort : constant Boolean := Triggered_By_Abort;
5566 -- Abort : constant Boolean := False; -- no abort
5568 -- E : Exception_Occurrence;
5569 -- Raised : Boolean := False;
5572 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5573 -- ^-- in the finalization case
5575 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5577 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5581 -- if not Raised then
5583 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5590 -- if Raised and then not Abort then
5591 -- Raise_From_Controlled_Operation (E);
5595 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5596 -- Create the statements necessary to initialize an array of controlled
5597 -- elements. Include a mechanism to carry out partial finalization if an
5598 -- exception occurs. Generate:
5601 -- Counter : Integer := 0;
5604 -- for J1 in V'Range (1) loop
5606 -- for JN in V'Range (N) loop
5608 -- [Deep_]Initialize (V (J1, ..., JN));
5610 -- Counter := Counter + 1;
5615 -- Abort : constant Boolean := Triggered_By_Abort;
5617 -- Abort : constant Boolean := False; -- no abort
5618 -- E : Exception_Occurrence;
5619 -- Raised : Boolean := False;
5626 -- V'Length (N) - Counter;
5628 -- for F1 in reverse V'Range (1) loop
5630 -- for FN in reverse V'Range (N) loop
5631 -- if Counter > 0 then
5632 -- Counter := Counter - 1;
5635 -- [Deep_]Finalize (V (F1, ..., FN));
5639 -- if not Raised then
5641 -- Save_Occurrence (E,
5642 -- Get_Current_Excep.all.all);
5651 -- if Raised and then not Abort then
5652 -- Raise_From_Controlled_Operation (E);
5661 function New_References_To
5663 Loc
: Source_Ptr
) return List_Id
;
5664 -- Given a list of defining identifiers, return a list of references to
5665 -- the original identifiers, in the same order as they appear.
5667 -----------------------------------------
5668 -- Build_Adjust_Or_Finalize_Statements --
5669 -----------------------------------------
5671 function Build_Adjust_Or_Finalize_Statements
5672 (Typ
: Entity_Id
) return List_Id
5674 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5675 Exceptions_OK
: constant Boolean :=
5676 not Restriction_Active
(No_Exception_Propagation
);
5677 Index_List
: constant List_Id
:= New_List
;
5678 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5679 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5681 Finalizer_Decls
: List_Id
:= No_List
;
5682 Finalizer_Data
: Finalization_Exception_Data
;
5685 Core_Loop
: Node_Id
;
5688 Loop_Id
: Entity_Id
;
5691 procedure Build_Indexes
;
5692 -- Generate the indexes used in the dimension loops
5698 procedure Build_Indexes
is
5700 -- Generate the following identifiers:
5701 -- Jnn - for initialization
5703 for Dim
in 1 .. Num_Dims
loop
5704 Append_To
(Index_List
,
5705 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5709 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5712 Finalizer_Decls
:= New_List
;
5715 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5718 Make_Indexed_Component
(Loc
,
5719 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5720 Expressions
=> New_References_To
(Index_List
, Loc
));
5721 Set_Etype
(Comp_Ref
, Comp_Typ
);
5724 -- [Deep_]Adjust (V (J1, ..., JN))
5726 if Prim
= Adjust_Case
then
5727 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5730 -- [Deep_]Finalize (V (J1, ..., JN))
5732 else pragma Assert
(Prim
= Finalize_Case
);
5733 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5736 -- Generate the block which houses the adjust or finalize call:
5739 -- <adjust or finalize call>
5743 -- if not Raised then
5745 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5749 if Exceptions_OK
then
5751 Make_Block_Statement
(Loc
,
5752 Handled_Statement_Sequence
=>
5753 Make_Handled_Sequence_Of_Statements
(Loc
,
5754 Statements
=> New_List
(Call
),
5755 Exception_Handlers
=> New_List
(
5756 Build_Exception_Handler
(Finalizer_Data
))));
5761 -- Generate the dimension loops starting from the innermost one
5763 -- for Jnn in [reverse] V'Range (Dim) loop
5767 J
:= Last
(Index_List
);
5769 while Present
(J
) and then Dim
> 0 loop
5775 Make_Loop_Statement
(Loc
,
5777 Make_Iteration_Scheme
(Loc
,
5778 Loop_Parameter_Specification
=>
5779 Make_Loop_Parameter_Specification
(Loc
,
5780 Defining_Identifier
=> Loop_Id
,
5781 Discrete_Subtype_Definition
=>
5782 Make_Attribute_Reference
(Loc
,
5783 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5784 Attribute_Name
=> Name_Range
,
5785 Expressions
=> New_List
(
5786 Make_Integer_Literal
(Loc
, Dim
))),
5788 Reverse_Present
=> Prim
= Finalize_Case
)),
5790 Statements
=> New_List
(Core_Loop
),
5791 End_Label
=> Empty
);
5796 -- Generate the block which contains the core loop, the declarations
5797 -- of the abort flag, the exception occurrence, the raised flag and
5798 -- the conditional raise:
5801 -- Abort : constant Boolean := Triggered_By_Abort;
5803 -- Abort : constant Boolean := False; -- no abort
5805 -- E : Exception_Occurrence;
5806 -- Raised : Boolean := False;
5811 -- if Raised and then not Abort then
5812 -- Raise_From_Controlled_Operation (E);
5816 Stmts
:= New_List
(Core_Loop
);
5818 if Exceptions_OK
then
5819 Append_To
(Stmts
, Build_Raise_Statement
(Finalizer_Data
));
5824 Make_Block_Statement
(Loc
,
5827 Handled_Statement_Sequence
=>
5828 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
)));
5829 end Build_Adjust_Or_Finalize_Statements
;
5831 ---------------------------------
5832 -- Build_Initialize_Statements --
5833 ---------------------------------
5835 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5836 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5837 Exceptions_OK
: constant Boolean :=
5838 not Restriction_Active
(No_Exception_Propagation
);
5839 Final_List
: constant List_Id
:= New_List
;
5840 Index_List
: constant List_Id
:= New_List
;
5841 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5842 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5844 Counter_Id
: Entity_Id
;
5848 Final_Block
: Node_Id
;
5849 Final_Loop
: Node_Id
;
5850 Finalizer_Data
: Finalization_Exception_Data
;
5851 Finalizer_Decls
: List_Id
:= No_List
;
5852 Init_Loop
: Node_Id
;
5857 function Build_Counter_Assignment
return Node_Id
;
5858 -- Generate the following assignment:
5859 -- Counter := V'Length (1) *
5861 -- V'Length (N) - Counter;
5863 function Build_Finalization_Call
return Node_Id
;
5864 -- Generate a deep finalization call for an array element
5866 procedure Build_Indexes
;
5867 -- Generate the initialization and finalization indexes used in the
5870 function Build_Initialization_Call
return Node_Id
;
5871 -- Generate a deep initialization call for an array element
5873 ------------------------------
5874 -- Build_Counter_Assignment --
5875 ------------------------------
5877 function Build_Counter_Assignment
return Node_Id
is
5882 -- Start from the first dimension and generate:
5887 Make_Attribute_Reference
(Loc
,
5888 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5889 Attribute_Name
=> Name_Length
,
5890 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5892 -- Process the rest of the dimensions, generate:
5893 -- Expr * V'Length (N)
5896 while Dim
<= Num_Dims
loop
5898 Make_Op_Multiply
(Loc
,
5901 Make_Attribute_Reference
(Loc
,
5902 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5903 Attribute_Name
=> Name_Length
,
5904 Expressions
=> New_List
(
5905 Make_Integer_Literal
(Loc
, Dim
))));
5911 -- Counter := Expr - Counter;
5914 Make_Assignment_Statement
(Loc
,
5915 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5917 Make_Op_Subtract
(Loc
,
5919 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5920 end Build_Counter_Assignment
;
5922 -----------------------------
5923 -- Build_Finalization_Call --
5924 -----------------------------
5926 function Build_Finalization_Call
return Node_Id
is
5927 Comp_Ref
: constant Node_Id
:=
5928 Make_Indexed_Component
(Loc
,
5929 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5930 Expressions
=> New_References_To
(Final_List
, Loc
));
5933 Set_Etype
(Comp_Ref
, Comp_Typ
);
5936 -- [Deep_]Finalize (V);
5938 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5939 end Build_Finalization_Call
;
5945 procedure Build_Indexes
is
5947 -- Generate the following identifiers:
5948 -- Jnn - for initialization
5949 -- Fnn - for finalization
5951 for Dim
in 1 .. Num_Dims
loop
5952 Append_To
(Index_List
,
5953 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5955 Append_To
(Final_List
,
5956 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5960 -------------------------------
5961 -- Build_Initialization_Call --
5962 -------------------------------
5964 function Build_Initialization_Call
return Node_Id
is
5965 Comp_Ref
: constant Node_Id
:=
5966 Make_Indexed_Component
(Loc
,
5967 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5968 Expressions
=> New_References_To
(Index_List
, Loc
));
5971 Set_Etype
(Comp_Ref
, Comp_Typ
);
5974 -- [Deep_]Initialize (V (J1, ..., JN));
5976 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5977 end Build_Initialization_Call
;
5979 -- Start of processing for Build_Initialize_Statements
5982 Counter_Id
:= Make_Temporary
(Loc
, 'C');
5983 Finalizer_Decls
:= New_List
;
5986 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
5988 -- Generate the block which houses the finalization call, the index
5989 -- guard and the handler which triggers Program_Error later on.
5991 -- if Counter > 0 then
5992 -- Counter := Counter - 1;
5995 -- [Deep_]Finalize (V (F1, ..., FN));
5998 -- if not Raised then
6000 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6005 if Exceptions_OK
then
6007 Make_Block_Statement
(Loc
,
6008 Handled_Statement_Sequence
=>
6009 Make_Handled_Sequence_Of_Statements
(Loc
,
6010 Statements
=> New_List
(Build_Finalization_Call
),
6011 Exception_Handlers
=> New_List
(
6012 Build_Exception_Handler
(Finalizer_Data
))));
6014 Fin_Stmt
:= Build_Finalization_Call
;
6017 -- This is the core of the loop, the dimension iterators are added
6018 -- one by one in reverse.
6021 Make_If_Statement
(Loc
,
6024 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6025 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6027 Then_Statements
=> New_List
(
6028 Make_Assignment_Statement
(Loc
,
6029 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6031 Make_Op_Subtract
(Loc
,
6032 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6033 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6035 Else_Statements
=> New_List
(Fin_Stmt
));
6037 -- Generate all finalization loops starting from the innermost
6040 -- for Fnn in reverse V'Range (Dim) loop
6044 F
:= Last
(Final_List
);
6046 while Present
(F
) and then Dim
> 0 loop
6052 Make_Loop_Statement
(Loc
,
6054 Make_Iteration_Scheme
(Loc
,
6055 Loop_Parameter_Specification
=>
6056 Make_Loop_Parameter_Specification
(Loc
,
6057 Defining_Identifier
=> Loop_Id
,
6058 Discrete_Subtype_Definition
=>
6059 Make_Attribute_Reference
(Loc
,
6060 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6061 Attribute_Name
=> Name_Range
,
6062 Expressions
=> New_List
(
6063 Make_Integer_Literal
(Loc
, Dim
))),
6065 Reverse_Present
=> True)),
6067 Statements
=> New_List
(Final_Loop
),
6068 End_Label
=> Empty
);
6073 -- Generate the block which contains the finalization loops, the
6074 -- declarations of the abort flag, the exception occurrence, the
6075 -- raised flag and the conditional raise.
6078 -- Abort : constant Boolean := Triggered_By_Abort;
6080 -- Abort : constant Boolean := False; -- no abort
6082 -- E : Exception_Occurrence;
6083 -- Raised : Boolean := False;
6089 -- V'Length (N) - Counter;
6093 -- if Raised and then not Abort then
6094 -- Raise_From_Controlled_Operation (E);
6100 Stmts
:= New_List
(Build_Counter_Assignment
, Final_Loop
);
6102 if Exceptions_OK
then
6103 Append_To
(Stmts
, Build_Raise_Statement
(Finalizer_Data
));
6104 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6108 Make_Block_Statement
(Loc
,
6111 Handled_Statement_Sequence
=>
6112 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
));
6114 -- Generate the block which contains the initialization call and
6115 -- the partial finalization code.
6118 -- [Deep_]Initialize (V (J1, ..., JN));
6120 -- Counter := Counter + 1;
6124 -- <finalization code>
6128 Make_Block_Statement
(Loc
,
6129 Handled_Statement_Sequence
=>
6130 Make_Handled_Sequence_Of_Statements
(Loc
,
6131 Statements
=> New_List
(Build_Initialization_Call
),
6132 Exception_Handlers
=> New_List
(
6133 Make_Exception_Handler
(Loc
,
6134 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
6135 Statements
=> New_List
(Final_Block
)))));
6137 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6138 Make_Assignment_Statement
(Loc
,
6139 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6142 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6143 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6145 -- Generate all initialization loops starting from the innermost
6148 -- for Jnn in V'Range (Dim) loop
6152 J
:= Last
(Index_List
);
6154 while Present
(J
) and then Dim
> 0 loop
6160 Make_Loop_Statement
(Loc
,
6162 Make_Iteration_Scheme
(Loc
,
6163 Loop_Parameter_Specification
=>
6164 Make_Loop_Parameter_Specification
(Loc
,
6165 Defining_Identifier
=> Loop_Id
,
6166 Discrete_Subtype_Definition
=>
6167 Make_Attribute_Reference
(Loc
,
6168 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6169 Attribute_Name
=> Name_Range
,
6170 Expressions
=> New_List
(
6171 Make_Integer_Literal
(Loc
, Dim
))))),
6173 Statements
=> New_List
(Init_Loop
),
6174 End_Label
=> Empty
);
6179 -- Generate the block which contains the counter variable and the
6180 -- initialization loops.
6183 -- Counter : Integer := 0;
6190 Make_Block_Statement
(Loc
,
6191 Declarations
=> New_List
(
6192 Make_Object_Declaration
(Loc
,
6193 Defining_Identifier
=> Counter_Id
,
6194 Object_Definition
=>
6195 New_Occurrence_Of
(Standard_Integer
, Loc
),
6196 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6198 Handled_Statement_Sequence
=>
6199 Make_Handled_Sequence_Of_Statements
(Loc
,
6200 Statements
=> New_List
(Init_Loop
))));
6201 end Build_Initialize_Statements
;
6203 -----------------------
6204 -- New_References_To --
6205 -----------------------
6207 function New_References_To
6209 Loc
: Source_Ptr
) return List_Id
6211 Refs
: constant List_Id
:= New_List
;
6216 while Present
(Id
) loop
6217 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6222 end New_References_To
;
6224 -- Start of processing for Make_Deep_Array_Body
6228 when Address_Case
=>
6229 return Make_Finalize_Address_Stmts
(Typ
);
6233 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6235 when Initialize_Case
=>
6236 return Build_Initialize_Statements
(Typ
);
6238 end Make_Deep_Array_Body
;
6240 --------------------
6241 -- Make_Deep_Proc --
6242 --------------------
6244 function Make_Deep_Proc
6245 (Prim
: Final_Primitives
;
6247 Stmts
: List_Id
) return Entity_Id
6249 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6251 Proc_Id
: Entity_Id
;
6254 -- Create the object formal, generate:
6255 -- V : System.Address
6257 if Prim
= Address_Case
then
6258 Formals
:= New_List
(
6259 Make_Parameter_Specification
(Loc
,
6260 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6262 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6269 Formals
:= New_List
(
6270 Make_Parameter_Specification
(Loc
,
6271 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6273 Out_Present
=> True,
6274 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6276 -- F : Boolean := True
6278 if Prim
= Adjust_Case
6279 or else Prim
= Finalize_Case
6282 Make_Parameter_Specification
(Loc
,
6283 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6285 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6287 New_Occurrence_Of
(Standard_True
, Loc
)));
6292 Make_Defining_Identifier
(Loc
,
6293 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6296 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6299 -- exception -- Finalize and Adjust cases only
6300 -- raise Program_Error;
6301 -- end Deep_Initialize / Adjust / Finalize;
6305 -- procedure Finalize_Address (V : System.Address) is
6308 -- end Finalize_Address;
6311 Make_Subprogram_Body
(Loc
,
6313 Make_Procedure_Specification
(Loc
,
6314 Defining_Unit_Name
=> Proc_Id
,
6315 Parameter_Specifications
=> Formals
),
6317 Declarations
=> Empty_List
,
6319 Handled_Statement_Sequence
=>
6320 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6325 ---------------------------
6326 -- Make_Deep_Record_Body --
6327 ---------------------------
6329 function Make_Deep_Record_Body
6330 (Prim
: Final_Primitives
;
6332 Is_Local
: Boolean := False) return List_Id
6334 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6335 -- Build the statements necessary to adjust a record type. The type may
6336 -- have discriminants and contain variant parts. Generate:
6340 -- [Deep_]Adjust (V.Comp_1);
6342 -- when Id : others =>
6343 -- if not Raised then
6345 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6350 -- [Deep_]Adjust (V.Comp_N);
6352 -- when Id : others =>
6353 -- if not Raised then
6355 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6360 -- Deep_Adjust (V._parent, False); -- If applicable
6362 -- when Id : others =>
6363 -- if not Raised then
6365 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6371 -- Adjust (V); -- If applicable
6374 -- if not Raised then
6376 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6381 -- if Raised and then not Abort then
6382 -- Raise_From_Controlled_Operation (E);
6386 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6387 -- Build the statements necessary to finalize a record type. The type
6388 -- may have discriminants and contain variant parts. Generate:
6391 -- Abort : constant Boolean := Triggered_By_Abort;
6393 -- Abort : constant Boolean := False; -- no abort
6394 -- E : Exception_Occurrence;
6395 -- Raised : Boolean := False;
6400 -- Finalize (V); -- If applicable
6403 -- if not Raised then
6405 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6410 -- case Variant_1 is
6412 -- case State_Counter_N => -- If Is_Local is enabled
6422 -- <<LN>> -- If Is_Local is enabled
6424 -- [Deep_]Finalize (V.Comp_N);
6427 -- if not Raised then
6429 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6435 -- [Deep_]Finalize (V.Comp_1);
6438 -- if not Raised then
6440 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6446 -- case State_Counter_1 => -- If Is_Local is enabled
6452 -- Deep_Finalize (V._parent, False); -- If applicable
6454 -- when Id : others =>
6455 -- if not Raised then
6457 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6461 -- if Raised and then not Abort then
6462 -- Raise_From_Controlled_Operation (E);
6466 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6467 -- Given a derived tagged type Typ, traverse all components, find field
6468 -- _parent and return its type.
6470 procedure Preprocess_Components
6472 Num_Comps
: out Nat
;
6473 Has_POC
: out Boolean);
6474 -- Examine all components in component list Comps, count all controlled
6475 -- components and determine whether at least one of them is per-object
6476 -- constrained. Component _parent is always skipped.
6478 -----------------------------
6479 -- Build_Adjust_Statements --
6480 -----------------------------
6482 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6483 Exceptions_OK
: constant Boolean :=
6484 not Restriction_Active
(No_Exception_Propagation
);
6485 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6486 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6488 Bod_Stmts
: List_Id
;
6489 Finalizer_Data
: Finalization_Exception_Data
;
6490 Finalizer_Decls
: List_Id
:= No_List
;
6494 function Process_Component_List_For_Adjust
6495 (Comps
: Node_Id
) return List_Id
;
6496 -- Build all necessary adjust statements for a single component list
6498 ---------------------------------------
6499 -- Process_Component_List_For_Adjust --
6500 ---------------------------------------
6502 function Process_Component_List_For_Adjust
6503 (Comps
: Node_Id
) return List_Id
6505 Stmts
: constant List_Id
:= New_List
;
6507 Decl_Id
: Entity_Id
;
6508 Decl_Typ
: Entity_Id
;
6512 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6513 -- Process the declaration of a single controlled component
6515 ----------------------------------
6516 -- Process_Component_For_Adjust --
6517 ----------------------------------
6519 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6520 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6521 Typ
: constant Entity_Id
:= Etype
(Id
);
6526 -- [Deep_]Adjust (V.Id);
6530 -- if not Raised then
6532 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6539 Make_Selected_Component
(Loc
,
6540 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6541 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6544 if Exceptions_OK
then
6546 Make_Block_Statement
(Loc
,
6547 Handled_Statement_Sequence
=>
6548 Make_Handled_Sequence_Of_Statements
(Loc
,
6549 Statements
=> New_List
(Adj_Stmt
),
6550 Exception_Handlers
=> New_List
(
6551 Build_Exception_Handler
(Finalizer_Data
))));
6554 Append_To
(Stmts
, Adj_Stmt
);
6555 end Process_Component_For_Adjust
;
6557 -- Start of processing for Process_Component_List_For_Adjust
6560 -- Perform an initial check, determine the number of controlled
6561 -- components in the current list and whether at least one of them
6562 -- is per-object constrained.
6564 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6566 -- The processing in this routine is done in the following order:
6567 -- 1) Regular components
6568 -- 2) Per-object constrained components
6571 if Num_Comps
> 0 then
6573 -- Process all regular components in order of declarations
6575 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6576 while Present
(Decl
) loop
6577 Decl_Id
:= Defining_Identifier
(Decl
);
6578 Decl_Typ
:= Etype
(Decl_Id
);
6580 -- Skip _parent as well as per-object constrained components
6582 if Chars
(Decl_Id
) /= Name_uParent
6583 and then Needs_Finalization
(Decl_Typ
)
6585 if Has_Access_Constraint
(Decl_Id
)
6586 and then No
(Expression
(Decl
))
6590 Process_Component_For_Adjust
(Decl
);
6594 Next_Non_Pragma
(Decl
);
6597 -- Process all per-object constrained components in order of
6601 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6602 while Present
(Decl
) loop
6603 Decl_Id
:= Defining_Identifier
(Decl
);
6604 Decl_Typ
:= Etype
(Decl_Id
);
6608 if Chars
(Decl_Id
) /= Name_uParent
6609 and then Needs_Finalization
(Decl_Typ
)
6610 and then Has_Access_Constraint
(Decl_Id
)
6611 and then No
(Expression
(Decl
))
6613 Process_Component_For_Adjust
(Decl
);
6616 Next_Non_Pragma
(Decl
);
6621 -- Process all variants, if any
6624 if Present
(Variant_Part
(Comps
)) then
6626 Var_Alts
: constant List_Id
:= New_List
;
6630 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6631 while Present
(Var
) loop
6634 -- when <discrete choices> =>
6635 -- <adjust statements>
6637 Append_To
(Var_Alts
,
6638 Make_Case_Statement_Alternative
(Loc
,
6640 New_Copy_List
(Discrete_Choices
(Var
)),
6642 Process_Component_List_For_Adjust
(
6643 Component_List
(Var
))));
6645 Next_Non_Pragma
(Var
);
6649 -- case V.<discriminant> is
6650 -- when <discrete choices 1> =>
6651 -- <adjust statements 1>
6653 -- when <discrete choices N> =>
6654 -- <adjust statements N>
6658 Make_Case_Statement
(Loc
,
6660 Make_Selected_Component
(Loc
,
6661 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6663 Make_Identifier
(Loc
,
6664 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6665 Alternatives
=> Var_Alts
);
6669 -- Add the variant case statement to the list of statements
6671 if Present
(Var_Case
) then
6672 Append_To
(Stmts
, Var_Case
);
6675 -- If the component list did not have any controlled components
6676 -- nor variants, return null.
6678 if Is_Empty_List
(Stmts
) then
6679 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6683 end Process_Component_List_For_Adjust
;
6685 -- Start of processing for Build_Adjust_Statements
6688 Finalizer_Decls
:= New_List
;
6689 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6691 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6692 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6697 -- Create an adjust sequence for all record components
6699 if Present
(Component_List
(Rec_Def
)) then
6701 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6704 -- A derived record type must adjust all inherited components. This
6705 -- action poses the following problem:
6707 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6712 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6714 -- Deep_Adjust (Obj._parent);
6719 -- Adjusting the derived type will invoke Adjust of the parent and
6720 -- then that of the derived type. This is undesirable because both
6721 -- routines may modify shared components. Only the Adjust of the
6722 -- derived type should be invoked.
6724 -- To prevent this double adjustment of shared components,
6725 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6727 -- procedure Deep_Adjust
6728 -- (Obj : in out Some_Type;
6729 -- Flag : Boolean := True)
6737 -- When Deep_Adjust is invokes for field _parent, a value of False is
6738 -- provided for the flag:
6740 -- Deep_Adjust (Obj._parent, False);
6742 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6744 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6749 if Needs_Finalization
(Par_Typ
) then
6753 Make_Selected_Component
(Loc
,
6754 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6756 Make_Identifier
(Loc
, Name_uParent
)),
6762 -- Deep_Adjust (V._parent, False);
6765 -- when Id : others =>
6766 -- if not Raised then
6768 -- Save_Occurrence (E,
6769 -- Get_Current_Excep.all.all);
6773 if Present
(Call
) then
6776 if Exceptions_OK
then
6778 Make_Block_Statement
(Loc
,
6779 Handled_Statement_Sequence
=>
6780 Make_Handled_Sequence_Of_Statements
(Loc
,
6781 Statements
=> New_List
(Adj_Stmt
),
6782 Exception_Handlers
=> New_List
(
6783 Build_Exception_Handler
(Finalizer_Data
))));
6786 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6792 -- Adjust the object. This action must be performed last after all
6793 -- components have been adjusted.
6795 if Is_Controlled
(Typ
) then
6801 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
6810 -- if not Raised then
6812 -- Save_Occurrence (E,
6813 -- Get_Current_Excep.all.all);
6818 if Present
(Proc
) then
6820 Make_Procedure_Call_Statement
(Loc
,
6821 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6822 Parameter_Associations
=> New_List
(
6823 Make_Identifier
(Loc
, Name_V
)));
6825 if Exceptions_OK
then
6827 Make_Block_Statement
(Loc
,
6828 Handled_Statement_Sequence
=>
6829 Make_Handled_Sequence_Of_Statements
(Loc
,
6830 Statements
=> New_List
(Adj_Stmt
),
6831 Exception_Handlers
=> New_List
(
6832 Build_Exception_Handler
6833 (Finalizer_Data
))));
6836 Append_To
(Bod_Stmts
,
6837 Make_If_Statement
(Loc
,
6838 Condition
=> Make_Identifier
(Loc
, Name_F
),
6839 Then_Statements
=> New_List
(Adj_Stmt
)));
6844 -- At this point either all adjustment statements have been generated
6845 -- or the type is not controlled.
6847 if Is_Empty_List
(Bod_Stmts
) then
6848 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6854 -- Abort : constant Boolean := Triggered_By_Abort;
6856 -- Abort : constant Boolean := False; -- no abort
6858 -- E : Exception_Occurrence;
6859 -- Raised : Boolean := False;
6862 -- <adjust statements>
6864 -- if Raised and then not Abort then
6865 -- Raise_From_Controlled_Operation (E);
6870 if Exceptions_OK
then
6871 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
6876 Make_Block_Statement
(Loc
,
6879 Handled_Statement_Sequence
=>
6880 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6882 end Build_Adjust_Statements
;
6884 -------------------------------
6885 -- Build_Finalize_Statements --
6886 -------------------------------
6888 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6889 Exceptions_OK
: constant Boolean :=
6890 not Restriction_Active
(No_Exception_Propagation
);
6891 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6892 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6894 Bod_Stmts
: List_Id
;
6896 Finalizer_Data
: Finalization_Exception_Data
;
6897 Finalizer_Decls
: List_Id
:= No_List
;
6901 function Process_Component_List_For_Finalize
6902 (Comps
: Node_Id
) return List_Id
;
6903 -- Build all necessary finalization statements for a single component
6904 -- list. The statements may include a jump circuitry if flag Is_Local
6907 -----------------------------------------
6908 -- Process_Component_List_For_Finalize --
6909 -----------------------------------------
6911 function Process_Component_List_For_Finalize
6912 (Comps
: Node_Id
) return List_Id
6915 Counter_Id
: Entity_Id
;
6917 Decl_Id
: Entity_Id
;
6918 Decl_Typ
: Entity_Id
;
6921 Jump_Block
: Node_Id
;
6923 Label_Id
: Entity_Id
;
6927 procedure Process_Component_For_Finalize
6932 -- Process the declaration of a single controlled component. If
6933 -- flag Is_Local is enabled, create the corresponding label and
6934 -- jump circuitry. Alts is the list of case alternatives, Decls
6935 -- is the top level declaration list where labels are declared
6936 -- and Stmts is the list of finalization actions.
6938 ------------------------------------
6939 -- Process_Component_For_Finalize --
6940 ------------------------------------
6942 procedure Process_Component_For_Finalize
6948 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6949 Typ
: constant Entity_Id
:= Etype
(Id
);
6956 Label_Id
: Entity_Id
;
6963 Make_Identifier
(Loc
,
6964 Chars
=> New_External_Name
('L', Num_Comps
));
6965 Set_Entity
(Label_Id
,
6966 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
6967 Label
:= Make_Label
(Loc
, Label_Id
);
6970 Make_Implicit_Label_Declaration
(Loc
,
6971 Defining_Identifier
=> Entity
(Label_Id
),
6972 Label_Construct
=> Label
));
6979 Make_Case_Statement_Alternative
(Loc
,
6980 Discrete_Choices
=> New_List
(
6981 Make_Integer_Literal
(Loc
, Num_Comps
)),
6983 Statements
=> New_List
(
6984 Make_Goto_Statement
(Loc
,
6986 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
6991 Append_To
(Stmts
, Label
);
6993 -- Decrease the number of components to be processed.
6994 -- This action yields a new Label_Id in future calls.
6996 Num_Comps
:= Num_Comps
- 1;
7001 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7003 -- begin -- Exception handlers allowed
7004 -- [Deep_]Finalize (V.Id);
7007 -- if not Raised then
7009 -- Save_Occurrence (E,
7010 -- Get_Current_Excep.all.all);
7017 Make_Selected_Component
(Loc
,
7018 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7019 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7022 if not Restriction_Active
(No_Exception_Propagation
) then
7024 Make_Block_Statement
(Loc
,
7025 Handled_Statement_Sequence
=>
7026 Make_Handled_Sequence_Of_Statements
(Loc
,
7027 Statements
=> New_List
(Fin_Stmt
),
7028 Exception_Handlers
=> New_List
(
7029 Build_Exception_Handler
(Finalizer_Data
))));
7032 Append_To
(Stmts
, Fin_Stmt
);
7033 end Process_Component_For_Finalize
;
7035 -- Start of processing for Process_Component_List_For_Finalize
7038 -- Perform an initial check, look for controlled and per-object
7039 -- constrained components.
7041 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7043 -- Create a state counter to service the current component list.
7044 -- This step is performed before the variants are inspected in
7045 -- order to generate the same state counter names as those from
7046 -- Build_Initialize_Statements.
7048 if Num_Comps
> 0 and then Is_Local
then
7049 Counter
:= Counter
+ 1;
7052 Make_Defining_Identifier
(Loc
,
7053 Chars
=> New_External_Name
('C', Counter
));
7056 -- Process the component in the following order:
7058 -- 2) Per-object constrained components
7059 -- 3) Regular components
7061 -- Start with the variant parts
7064 if Present
(Variant_Part
(Comps
)) then
7066 Var_Alts
: constant List_Id
:= New_List
;
7070 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7071 while Present
(Var
) loop
7074 -- when <discrete choices> =>
7075 -- <finalize statements>
7077 Append_To
(Var_Alts
,
7078 Make_Case_Statement_Alternative
(Loc
,
7080 New_Copy_List
(Discrete_Choices
(Var
)),
7082 Process_Component_List_For_Finalize
(
7083 Component_List
(Var
))));
7085 Next_Non_Pragma
(Var
);
7089 -- case V.<discriminant> is
7090 -- when <discrete choices 1> =>
7091 -- <finalize statements 1>
7093 -- when <discrete choices N> =>
7094 -- <finalize statements N>
7098 Make_Case_Statement
(Loc
,
7100 Make_Selected_Component
(Loc
,
7101 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7103 Make_Identifier
(Loc
,
7104 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7105 Alternatives
=> Var_Alts
);
7109 -- The current component list does not have a single controlled
7110 -- component, however it may contain variants. Return the case
7111 -- statement for the variants or nothing.
7113 if Num_Comps
= 0 then
7114 if Present
(Var_Case
) then
7115 return New_List
(Var_Case
);
7117 return New_List
(Make_Null_Statement
(Loc
));
7121 -- Prepare all lists
7127 -- Process all per-object constrained components in reverse order
7130 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7131 while Present
(Decl
) loop
7132 Decl_Id
:= Defining_Identifier
(Decl
);
7133 Decl_Typ
:= Etype
(Decl_Id
);
7137 if Chars
(Decl_Id
) /= Name_uParent
7138 and then Needs_Finalization
(Decl_Typ
)
7139 and then Has_Access_Constraint
(Decl_Id
)
7140 and then No
(Expression
(Decl
))
7142 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
7145 Prev_Non_Pragma
(Decl
);
7149 -- Process the rest of the components in reverse order
7151 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7152 while Present
(Decl
) loop
7153 Decl_Id
:= Defining_Identifier
(Decl
);
7154 Decl_Typ
:= Etype
(Decl_Id
);
7158 if Chars
(Decl_Id
) /= Name_uParent
7159 and then Needs_Finalization
(Decl_Typ
)
7161 -- Skip per-object constrained components since they were
7162 -- handled in the above step.
7164 if Has_Access_Constraint
(Decl_Id
)
7165 and then No
(Expression
(Decl
))
7169 Process_Component_For_Finalize
(Decl
, Alts
, Decls
, Stmts
);
7173 Prev_Non_Pragma
(Decl
);
7178 -- LN : label; -- If Is_Local is enabled
7183 -- case CounterX is .
7193 -- <<LN>> -- If Is_Local is enabled
7195 -- [Deep_]Finalize (V.CompY);
7197 -- when Id : others =>
7198 -- if not Raised then
7200 -- Save_Occurrence (E,
7201 -- Get_Current_Excep.all.all);
7205 -- <<L0>> -- If Is_Local is enabled
7210 -- Add the declaration of default jump location L0, its
7211 -- corresponding alternative and its place in the statements.
7213 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7214 Set_Entity
(Label_Id
,
7215 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7216 Label
:= Make_Label
(Loc
, Label_Id
);
7218 Append_To
(Decls
, -- declaration
7219 Make_Implicit_Label_Declaration
(Loc
,
7220 Defining_Identifier
=> Entity
(Label_Id
),
7221 Label_Construct
=> Label
));
7223 Append_To
(Alts
, -- alternative
7224 Make_Case_Statement_Alternative
(Loc
,
7225 Discrete_Choices
=> New_List
(
7226 Make_Others_Choice
(Loc
)),
7228 Statements
=> New_List
(
7229 Make_Goto_Statement
(Loc
,
7230 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7232 Append_To
(Stmts
, Label
); -- statement
7234 -- Create the jump block
7237 Make_Case_Statement
(Loc
,
7238 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7239 Alternatives
=> Alts
));
7243 Make_Block_Statement
(Loc
,
7244 Declarations
=> Decls
,
7245 Handled_Statement_Sequence
=>
7246 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7248 if Present
(Var_Case
) then
7249 return New_List
(Var_Case
, Jump_Block
);
7251 return New_List
(Jump_Block
);
7253 end Process_Component_List_For_Finalize
;
7255 -- Start of processing for Build_Finalize_Statements
7258 Finalizer_Decls
:= New_List
;
7259 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7261 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7262 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7267 -- Create a finalization sequence for all record components
7269 if Present
(Component_List
(Rec_Def
)) then
7271 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7274 -- A derived record type must finalize all inherited components. This
7275 -- action poses the following problem:
7277 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7282 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7284 -- Deep_Finalize (Obj._parent);
7289 -- Finalizing the derived type will invoke Finalize of the parent and
7290 -- then that of the derived type. This is undesirable because both
7291 -- routines may modify shared components. Only the Finalize of the
7292 -- derived type should be invoked.
7294 -- To prevent this double adjustment of shared components,
7295 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7297 -- procedure Deep_Finalize
7298 -- (Obj : in out Some_Type;
7299 -- Flag : Boolean := True)
7307 -- When Deep_Finalize is invoked for field _parent, a value of False
7308 -- is provided for the flag:
7310 -- Deep_Finalize (Obj._parent, False);
7312 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7314 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7319 if Needs_Finalization
(Par_Typ
) then
7323 Make_Selected_Component
(Loc
,
7324 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7326 Make_Identifier
(Loc
, Name_uParent
)),
7332 -- Deep_Finalize (V._parent, False);
7335 -- when Id : others =>
7336 -- if not Raised then
7338 -- Save_Occurrence (E,
7339 -- Get_Current_Excep.all.all);
7343 if Present
(Call
) then
7346 if Exceptions_OK
then
7348 Make_Block_Statement
(Loc
,
7349 Handled_Statement_Sequence
=>
7350 Make_Handled_Sequence_Of_Statements
(Loc
,
7351 Statements
=> New_List
(Fin_Stmt
),
7352 Exception_Handlers
=> New_List
(
7353 Build_Exception_Handler
7354 (Finalizer_Data
))));
7357 Append_To
(Bod_Stmts
, Fin_Stmt
);
7363 -- Finalize the object. This action must be performed first before
7364 -- all components have been finalized.
7366 if Is_Controlled
(Typ
) and then not Is_Local
then
7372 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7381 -- if not Raised then
7383 -- Save_Occurrence (E,
7384 -- Get_Current_Excep.all.all);
7389 if Present
(Proc
) then
7391 Make_Procedure_Call_Statement
(Loc
,
7392 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7393 Parameter_Associations
=> New_List
(
7394 Make_Identifier
(Loc
, Name_V
)));
7396 if Exceptions_OK
then
7398 Make_Block_Statement
(Loc
,
7399 Handled_Statement_Sequence
=>
7400 Make_Handled_Sequence_Of_Statements
(Loc
,
7401 Statements
=> New_List
(Fin_Stmt
),
7402 Exception_Handlers
=> New_List
(
7403 Build_Exception_Handler
7404 (Finalizer_Data
))));
7407 Prepend_To
(Bod_Stmts
,
7408 Make_If_Statement
(Loc
,
7409 Condition
=> Make_Identifier
(Loc
, Name_F
),
7410 Then_Statements
=> New_List
(Fin_Stmt
)));
7415 -- At this point either all finalization statements have been
7416 -- generated or the type is not controlled.
7418 if No
(Bod_Stmts
) then
7419 return New_List
(Make_Null_Statement
(Loc
));
7423 -- Abort : constant Boolean := Triggered_By_Abort;
7425 -- Abort : constant Boolean := False; -- no abort
7427 -- E : Exception_Occurrence;
7428 -- Raised : Boolean := False;
7431 -- <finalize statements>
7433 -- if Raised and then not Abort then
7434 -- Raise_From_Controlled_Operation (E);
7439 if Exceptions_OK
then
7440 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7445 Make_Block_Statement
(Loc
,
7448 Handled_Statement_Sequence
=>
7449 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7451 end Build_Finalize_Statements
;
7453 -----------------------
7454 -- Parent_Field_Type --
7455 -----------------------
7457 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7461 Field
:= First_Entity
(Typ
);
7462 while Present
(Field
) loop
7463 if Chars
(Field
) = Name_uParent
then
7464 return Etype
(Field
);
7467 Next_Entity
(Field
);
7470 -- A derived tagged type should always have a parent field
7472 raise Program_Error
;
7473 end Parent_Field_Type
;
7475 ---------------------------
7476 -- Preprocess_Components --
7477 ---------------------------
7479 procedure Preprocess_Components
7481 Num_Comps
: out Nat
;
7482 Has_POC
: out Boolean)
7492 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7493 while Present
(Decl
) loop
7494 Id
:= Defining_Identifier
(Decl
);
7497 -- Skip field _parent
7499 if Chars
(Id
) /= Name_uParent
7500 and then Needs_Finalization
(Typ
)
7502 Num_Comps
:= Num_Comps
+ 1;
7504 if Has_Access_Constraint
(Id
)
7505 and then No
(Expression
(Decl
))
7511 Next_Non_Pragma
(Decl
);
7513 end Preprocess_Components
;
7515 -- Start of processing for Make_Deep_Record_Body
7519 when Address_Case
=>
7520 return Make_Finalize_Address_Stmts
(Typ
);
7523 return Build_Adjust_Statements
(Typ
);
7525 when Finalize_Case
=>
7526 return Build_Finalize_Statements
(Typ
);
7528 when Initialize_Case
=>
7530 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7533 if Is_Controlled
(Typ
) then
7535 Make_Procedure_Call_Statement
(Loc
,
7538 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7539 Parameter_Associations
=> New_List
(
7540 Make_Identifier
(Loc
, Name_V
))));
7546 end Make_Deep_Record_Body
;
7548 ----------------------
7549 -- Make_Final_Call --
7550 ----------------------
7552 function Make_Final_Call
7555 Skip_Self
: Boolean := False) return Node_Id
7557 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7559 Fin_Id
: Entity_Id
:= Empty
;
7564 -- Recover the proper type which contains [Deep_]Finalize
7566 if Is_Class_Wide_Type
(Typ
) then
7567 Utyp
:= Root_Type
(Typ
);
7571 elsif Is_Concurrent_Type
(Typ
) then
7572 Utyp
:= Corresponding_Record_Type
(Typ
);
7574 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
7576 elsif Is_Private_Type
(Typ
)
7577 and then Present
(Full_View
(Typ
))
7578 and then Is_Concurrent_Type
(Full_View
(Typ
))
7580 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7582 Ref
:= Convert_Concurrent
(Obj_Ref
, Full_View
(Typ
));
7590 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7591 Set_Assignment_OK
(Ref
);
7593 -- Deal with untagged derivation of private views. If the parent type
7594 -- is a protected type, Deep_Finalize is found on the corresponding
7595 -- record of the ancestor.
7597 if Is_Untagged_Derivation
(Typ
) then
7598 if Is_Protected_Type
(Typ
) then
7599 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7601 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7603 if Is_Protected_Type
(Utyp
) then
7604 Utyp
:= Corresponding_Record_Type
(Utyp
);
7608 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7609 Set_Assignment_OK
(Ref
);
7612 -- Deal with derived private types which do not inherit primitives from
7613 -- their parents. In this case, [Deep_]Finalize can be found in the full
7614 -- view of the parent type.
7616 if Is_Tagged_Type
(Utyp
)
7617 and then Is_Derived_Type
(Utyp
)
7618 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7619 and then Is_Private_Type
(Etype
(Utyp
))
7620 and then Present
(Full_View
(Etype
(Utyp
)))
7622 Utyp
:= Full_View
(Etype
(Utyp
));
7623 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7624 Set_Assignment_OK
(Ref
);
7627 -- When dealing with the completion of a private type, use the base type
7630 if Utyp
/= Base_Type
(Utyp
) then
7631 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7633 Utyp
:= Base_Type
(Utyp
);
7634 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7635 Set_Assignment_OK
(Ref
);
7639 if Has_Controlled_Component
(Utyp
) then
7640 if Is_Tagged_Type
(Utyp
) then
7641 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7643 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7647 -- Class-wide types, interfaces and types with controlled components
7649 elsif Is_Class_Wide_Type
(Typ
)
7650 or else Is_Interface
(Typ
)
7651 or else Has_Controlled_Component
(Utyp
)
7653 if Is_Tagged_Type
(Utyp
) then
7654 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7656 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7659 -- Derivations from [Limited_]Controlled
7661 elsif Is_Controlled
(Utyp
) then
7662 if Has_Controlled_Component
(Utyp
) then
7663 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7665 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7670 elsif Is_Tagged_Type
(Utyp
) then
7671 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7674 raise Program_Error
;
7677 if Present
(Fin_Id
) then
7679 -- When finalizing a class-wide object, do not convert to the root
7680 -- type in order to produce a dispatching call.
7682 if Is_Class_Wide_Type
(Typ
) then
7685 -- Ensure that a finalization routine is at least decorated in order
7686 -- to inspect the object parameter.
7688 elsif Analyzed
(Fin_Id
)
7689 or else Ekind
(Fin_Id
) = E_Procedure
7691 -- In certain cases, such as the creation of Stream_Read, the
7692 -- visible entity of the type is its full view. Since Stream_Read
7693 -- will have to create an object of type Typ, the local object
7694 -- will be finalzed by the scope finalizer generated later on. The
7695 -- object parameter of Deep_Finalize will always use the private
7696 -- view of the type. To avoid such a clash between a private and a
7697 -- full view, perform an unchecked conversion of the object
7698 -- reference to the private view.
7701 Formal_Typ
: constant Entity_Id
:=
7702 Etype
(First_Formal
(Fin_Id
));
7704 if Is_Private_Type
(Formal_Typ
)
7705 and then Present
(Full_View
(Formal_Typ
))
7706 and then Full_View
(Formal_Typ
) = Utyp
7708 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7712 Ref
:= Convert_View
(Fin_Id
, Ref
);
7718 Param
=> New_Copy_Tree
(Ref
),
7719 Skip_Self
=> Skip_Self
);
7723 end Make_Final_Call
;
7725 --------------------------------
7726 -- Make_Finalize_Address_Body --
7727 --------------------------------
7729 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7730 Is_Task
: constant Boolean :=
7731 Ekind
(Typ
) = E_Record_Type
7732 and then Is_Concurrent_Record_Type
(Typ
)
7733 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7735 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7736 Proc_Id
: Entity_Id
;
7740 -- The corresponding records of task types are not controlled by design.
7741 -- For the sake of completeness, create an empty Finalize_Address to be
7742 -- used in task class-wide allocations.
7747 -- Nothing to do if the type is not controlled or it already has a
7748 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7749 -- come from source. These are usually generated for completeness and
7750 -- do not need the Finalize_Address primitive.
7752 elsif not Needs_Finalization
(Typ
)
7753 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7755 (Is_Class_Wide_Type
(Typ
)
7756 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7757 and then not Comes_From_Source
(Root_Type
(Typ
)))
7763 Make_Defining_Identifier
(Loc
,
7764 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7768 -- procedure <Typ>FD (V : System.Address) is
7770 -- null; -- for tasks
7772 -- declare -- for all other types
7773 -- type Pnn is access all Typ;
7774 -- for Pnn'Storage_Size use 0;
7776 -- [Deep_]Finalize (Pnn (V).all);
7781 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7783 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7787 Make_Subprogram_Body
(Loc
,
7789 Make_Procedure_Specification
(Loc
,
7790 Defining_Unit_Name
=> Proc_Id
,
7792 Parameter_Specifications
=> New_List
(
7793 Make_Parameter_Specification
(Loc
,
7794 Defining_Identifier
=>
7795 Make_Defining_Identifier
(Loc
, Name_V
),
7797 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7799 Declarations
=> No_List
,
7801 Handled_Statement_Sequence
=>
7802 Make_Handled_Sequence_Of_Statements
(Loc
,
7803 Statements
=> Stmts
)));
7805 Set_TSS
(Typ
, Proc_Id
);
7806 end Make_Finalize_Address_Body
;
7808 ---------------------------------
7809 -- Make_Finalize_Address_Stmts --
7810 ---------------------------------
7812 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7813 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7814 Ptr_Typ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7816 Desg_Typ
: Entity_Id
;
7820 if Is_Array_Type
(Typ
) then
7821 if Is_Constrained
(First_Subtype
(Typ
)) then
7822 Desg_Typ
:= First_Subtype
(Typ
);
7824 Desg_Typ
:= Base_Type
(Typ
);
7827 -- Class-wide types of constrained root types
7829 elsif Is_Class_Wide_Type
(Typ
)
7830 and then Has_Discriminants
(Root_Type
(Typ
))
7832 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7835 Parent_Typ
: Entity_Id
;
7838 -- Climb the parent type chain looking for a non-constrained type
7840 Parent_Typ
:= Root_Type
(Typ
);
7841 while Parent_Typ
/= Etype
(Parent_Typ
)
7842 and then Has_Discriminants
(Parent_Typ
)
7844 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7846 Parent_Typ
:= Etype
(Parent_Typ
);
7849 -- Handle views created for tagged types with unknown
7852 if Is_Underlying_Record_View
(Parent_Typ
) then
7853 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7856 Desg_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7866 -- type Ptr_Typ is access all Typ;
7867 -- for Ptr_Typ'Storage_Size use 0;
7870 Make_Full_Type_Declaration
(Loc
,
7871 Defining_Identifier
=> Ptr_Typ
,
7873 Make_Access_To_Object_Definition
(Loc
,
7874 All_Present
=> True,
7875 Subtype_Indication
=> New_Occurrence_Of
(Desg_Typ
, Loc
))),
7877 Make_Attribute_Definition_Clause
(Loc
,
7878 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7879 Chars
=> Name_Storage_Size
,
7880 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7882 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7884 -- Unconstrained arrays require special processing in order to retrieve
7885 -- the elements. To achieve this, we have to skip the dope vector which
7886 -- lays in front of the elements and then use a thin pointer to perform
7887 -- the address-to-access conversion.
7889 if Is_Array_Type
(Typ
)
7890 and then not Is_Constrained
(First_Subtype
(Typ
))
7893 Dope_Id
: Entity_Id
;
7896 -- Ensure that Ptr_Typ a thin pointer, generate:
7897 -- for Ptr_Typ'Size use System.Address'Size;
7900 Make_Attribute_Definition_Clause
(Loc
,
7901 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7904 Make_Integer_Literal
(Loc
, System_Address_Size
)));
7907 -- Dnn : constant Storage_Offset :=
7908 -- Desg_Typ'Descriptor_Size / Storage_Unit;
7910 Dope_Id
:= Make_Temporary
(Loc
, 'D');
7913 Make_Object_Declaration
(Loc
,
7914 Defining_Identifier
=> Dope_Id
,
7915 Constant_Present
=> True,
7916 Object_Definition
=>
7917 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7919 Make_Op_Divide
(Loc
,
7921 Make_Attribute_Reference
(Loc
,
7922 Prefix
=> New_Occurrence_Of
(Desg_Typ
, Loc
),
7923 Attribute_Name
=> Name_Descriptor_Size
),
7925 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
7927 -- Shift the address from the start of the dope vector to the
7928 -- start of the elements:
7932 -- Note that this is done through a wrapper routine since RTSfind
7933 -- cannot retrieve operations with string names of the form "+".
7936 Make_Function_Call
(Loc
,
7938 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
7939 Parameter_Associations
=> New_List
(
7941 New_Occurrence_Of
(Dope_Id
, Loc
)));
7945 -- Create the block and the finalization call
7948 Make_Block_Statement
(Loc
,
7949 Declarations
=> Decls
,
7951 Handled_Statement_Sequence
=>
7952 Make_Handled_Sequence_Of_Statements
(Loc
,
7953 Statements
=> New_List
(
7956 Make_Explicit_Dereference
(Loc
,
7957 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
7958 Typ
=> Desg_Typ
)))));
7959 end Make_Finalize_Address_Stmts
;
7961 -------------------------------------
7962 -- Make_Handler_For_Ctrl_Operation --
7963 -------------------------------------
7967 -- when E : others =>
7968 -- Raise_From_Controlled_Operation (E);
7973 -- raise Program_Error [finalize raised exception];
7975 -- depending on whether Raise_From_Controlled_Operation is available
7977 function Make_Handler_For_Ctrl_Operation
7978 (Loc
: Source_Ptr
) return Node_Id
7981 -- Choice parameter (for the first case above)
7983 Raise_Node
: Node_Id
;
7984 -- Procedure call or raise statement
7987 -- Standard run-time: add choice parameter E and pass it to
7988 -- Raise_From_Controlled_Operation so that the original exception
7989 -- name and message can be recorded in the exception message for
7992 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
7993 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
7995 Make_Procedure_Call_Statement
(Loc
,
7998 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
7999 Parameter_Associations
=> New_List
(
8000 New_Occurrence_Of
(E_Occ
, Loc
)));
8002 -- Restricted run-time: exception messages are not supported
8007 Make_Raise_Program_Error
(Loc
,
8008 Reason
=> PE_Finalize_Raised_Exception
);
8012 Make_Implicit_Exception_Handler
(Loc
,
8013 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8014 Choice_Parameter
=> E_Occ
,
8015 Statements
=> New_List
(Raise_Node
));
8016 end Make_Handler_For_Ctrl_Operation
;
8018 --------------------
8019 -- Make_Init_Call --
8020 --------------------
8022 function Make_Init_Call
8024 Typ
: Entity_Id
) return Node_Id
8026 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8033 -- Deal with the type and object reference. Depending on the context, an
8034 -- object reference may need several conversions.
8036 if Is_Concurrent_Type
(Typ
) then
8038 Utyp
:= Corresponding_Record_Type
(Typ
);
8039 Ref
:= Convert_Concurrent
(Obj_Ref
, Typ
);
8041 elsif Is_Private_Type
(Typ
)
8042 and then Present
(Full_View
(Typ
))
8043 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8046 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8047 Ref
:= Convert_Concurrent
(Obj_Ref
, Underlying_Type
(Typ
));
8055 Set_Assignment_OK
(Ref
);
8057 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8059 -- Deal with untagged derivation of private views
8061 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8062 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8063 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8065 -- The following is to prevent problems with UC see 1.156 RH ???
8067 Set_Assignment_OK
(Ref
);
8070 -- If the underlying_type is a subtype, then we are dealing with the
8071 -- completion of a private type. We need to access the base type and
8072 -- generate a conversion to it.
8074 if Utyp
/= Base_Type
(Utyp
) then
8075 pragma Assert
(Is_Private_Type
(Typ
));
8076 Utyp
:= Base_Type
(Utyp
);
8077 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8080 -- Select the appropriate version of initialize
8082 if Has_Controlled_Component
(Utyp
) then
8083 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8085 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8086 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8089 -- The object reference may need another conversion depending on the
8090 -- type of the formal and that of the actual.
8092 Ref
:= Convert_View
(Proc
, Ref
);
8095 -- [Deep_]Initialize (Ref);
8098 Make_Procedure_Call_Statement
(Loc
,
8100 New_Occurrence_Of
(Proc
, Loc
),
8101 Parameter_Associations
=> New_List
(Ref
));
8104 ------------------------------
8105 -- Make_Local_Deep_Finalize --
8106 ------------------------------
8108 function Make_Local_Deep_Finalize
8110 Nam
: Entity_Id
) return Node_Id
8112 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8116 Formals
:= New_List
(
8120 Make_Parameter_Specification
(Loc
,
8121 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8123 Out_Present
=> True,
8124 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8126 -- F : Boolean := True
8128 Make_Parameter_Specification
(Loc
,
8129 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8130 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8131 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8133 -- Add the necessary number of counters to represent the initialization
8134 -- state of an object.
8137 Make_Subprogram_Body
(Loc
,
8139 Make_Procedure_Specification
(Loc
,
8140 Defining_Unit_Name
=> Nam
,
8141 Parameter_Specifications
=> Formals
),
8143 Declarations
=> No_List
,
8145 Handled_Statement_Sequence
=>
8146 Make_Handled_Sequence_Of_Statements
(Loc
,
8147 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8148 end Make_Local_Deep_Finalize
;
8150 ------------------------------------
8151 -- Make_Set_Finalize_Address_Call --
8152 ------------------------------------
8154 function Make_Set_Finalize_Address_Call
8156 Ptr_Typ
: Entity_Id
) return Node_Id
8158 -- It is possible for Ptr_Typ to be a partial view, if the access type
8159 -- is a full view declared in the private part of a nested package, and
8160 -- the finalization actions take place when completing analysis of the
8161 -- enclosing unit. For this reason use Underlying_Type twice below.
8163 Desig_Typ
: constant Entity_Id
:=
8165 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8166 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8167 Fin_Mas
: constant Entity_Id
:=
8168 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8171 -- Both the finalization master and primitive Finalize_Address must be
8174 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8177 -- Set_Finalize_Address
8178 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8181 Make_Procedure_Call_Statement
(Loc
,
8183 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8184 Parameter_Associations
=> New_List
(
8185 New_Occurrence_Of
(Fin_Mas
, Loc
),
8187 Make_Attribute_Reference
(Loc
,
8188 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8189 Attribute_Name
=> Name_Unrestricted_Access
)));
8190 end Make_Set_Finalize_Address_Call
;
8192 --------------------------
8193 -- Make_Transient_Block --
8194 --------------------------
8196 function Make_Transient_Block
8199 Par
: Node_Id
) return Node_Id
8201 Decls
: constant List_Id
:= New_List
;
8202 Instrs
: constant List_Id
:= New_List
(Action
);
8207 -- Case where only secondary stack use is involved
8209 if Uses_Sec_Stack
(Current_Scope
)
8210 and then Nkind
(Action
) /= N_Simple_Return_Statement
8211 and then Nkind
(Par
) /= N_Exception_Handler
8217 S
:= Scope
(Current_Scope
);
8219 -- At the outer level, no need to release the sec stack
8221 if S
= Standard_Standard
then
8222 Set_Uses_Sec_Stack
(Current_Scope
, False);
8225 -- In a function, only release the sec stack if the function
8226 -- does not return on the sec stack otherwise the result may
8227 -- be lost. The caller is responsible for releasing.
8229 elsif Ekind
(S
) = E_Function
then
8230 Set_Uses_Sec_Stack
(Current_Scope
, False);
8232 if not Requires_Transient_Scope
(Etype
(S
)) then
8233 Set_Uses_Sec_Stack
(S
, True);
8234 Check_Restriction
(No_Secondary_Stack
, Action
);
8239 -- In a loop or entry we should install a block encompassing
8240 -- all the construct. For now just release right away.
8242 elsif Ekind_In
(S
, E_Entry
, E_Loop
) then
8245 -- In a procedure or a block, release the sec stack on exit
8246 -- from the construct. Note that an exception handler with a
8247 -- choice parameter requires a declarative region in the form
8248 -- of a block. The block does not physically manifest in the
8249 -- tree as it only serves as a scope. Do not consider such a
8250 -- block because it will never release the sec stack.
8252 -- ??? Memory leak can be created by recursive calls
8254 elsif Ekind
(S
) = E_Procedure
8255 or else (Ekind
(S
) = E_Block
8256 and then not Is_Exception_Handler
(S
))
8258 Set_Uses_Sec_Stack
(Current_Scope
, False);
8259 Set_Uses_Sec_Stack
(S
, True);
8260 Check_Restriction
(No_Secondary_Stack
, Action
);
8270 -- Create the transient block. Set the parent now since the block itself
8271 -- is not part of the tree. The current scope is the E_Block entity
8272 -- that has been pushed by Establish_Transient_Scope.
8274 pragma Assert
(Ekind
(Current_Scope
) = E_Block
);
8276 Make_Block_Statement
(Loc
,
8277 Identifier
=> New_Occurrence_Of
(Current_Scope
, Loc
),
8278 Declarations
=> Decls
,
8279 Handled_Statement_Sequence
=>
8280 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8281 Has_Created_Identifier
=> True);
8282 Set_Parent
(Block
, Par
);
8284 -- Insert actions stuck in the transient scopes as well as all freezing
8285 -- nodes needed by those actions. Do not insert cleanup actions here,
8286 -- they will be transferred to the newly created block.
8288 Insert_Actions_In_Scope_Around
8289 (Action
, Clean
=> False, Manage_SS
=> False);
8291 Insert
:= Prev
(Action
);
8292 if Present
(Insert
) then
8293 Freeze_All
(First_Entity
(Current_Scope
), Insert
);
8296 -- Transfer cleanup actions to the newly created block
8299 Cleanup_Actions
: List_Id
8300 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8301 Actions_To_Be_Wrapped
(Cleanup
);
8303 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8304 Cleanup_Actions
:= No_List
;
8307 -- When the transient scope was established, we pushed the entry for the
8308 -- transient scope onto the scope stack, so that the scope was active
8309 -- for the installation of finalizable entities etc. Now we must remove
8310 -- this entry, since we have constructed a proper block.
8315 end Make_Transient_Block
;
8317 ------------------------
8318 -- Node_To_Be_Wrapped --
8319 ------------------------
8321 function Node_To_Be_Wrapped
return Node_Id
is
8323 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8324 end Node_To_Be_Wrapped
;
8326 ----------------------------
8327 -- Set_Node_To_Be_Wrapped --
8328 ----------------------------
8330 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8332 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8333 end Set_Node_To_Be_Wrapped
;
8335 ----------------------------
8336 -- Store_Actions_In_Scope --
8337 ----------------------------
8339 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8340 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8341 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8344 if No
(Actions
) then
8347 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8348 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8350 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8355 elsif AK
= Before
then
8356 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8359 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8361 end Store_Actions_In_Scope
;
8363 ----------------------------------
8364 -- Store_After_Actions_In_Scope --
8365 ----------------------------------
8367 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8369 Store_Actions_In_Scope
(After
, L
);
8370 end Store_After_Actions_In_Scope
;
8372 -----------------------------------
8373 -- Store_Before_Actions_In_Scope --
8374 -----------------------------------
8376 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8378 Store_Actions_In_Scope
(Before
, L
);
8379 end Store_Before_Actions_In_Scope
;
8381 -----------------------------------
8382 -- Store_Cleanup_Actions_In_Scope --
8383 -----------------------------------
8385 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8387 Store_Actions_In_Scope
(Cleanup
, L
);
8388 end Store_Cleanup_Actions_In_Scope
;
8390 --------------------------------
8391 -- Wrap_Transient_Declaration --
8392 --------------------------------
8394 -- If a transient scope has been established during the processing of the
8395 -- Expression of an Object_Declaration, it is not possible to wrap the
8396 -- declaration into a transient block as usual case, otherwise the object
8397 -- would be itself declared in the wrong scope. Therefore, all entities (if
8398 -- any) defined in the transient block are moved to the proper enclosing
8399 -- scope. Furthermore, if they are controlled variables they are finalized
8400 -- right after the declaration. The finalization list of the transient
8401 -- scope is defined as a renaming of the enclosing one so during their
8402 -- initialization they will be attached to the proper finalization list.
8403 -- For instance, the following declaration :
8405 -- X : Typ := F (G (A), G (B));
8407 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8408 -- is expanded into :
8410 -- X : Typ := [ complex Expression-Action ];
8411 -- [Deep_]Finalize (_v1);
8412 -- [Deep_]Finalize (_v2);
8414 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8419 Curr_S
:= Current_Scope
;
8420 Encl_S
:= Scope
(Curr_S
);
8422 -- Insert all actions including cleanup generated while analyzing or
8423 -- expanding the transient context back into the tree. Manage the
8424 -- secondary stack when the object declaration appears in a library
8425 -- level package [body].
8427 Insert_Actions_In_Scope_Around
8431 Uses_Sec_Stack
(Curr_S
)
8432 and then Nkind
(N
) = N_Object_Declaration
8433 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8434 and then Is_Library_Level_Entity
(Encl_S
));
8437 -- Relocate local entities declared within the transient scope to the
8438 -- enclosing scope. This action sets their Is_Public flag accordingly.
8440 Transfer_Entities
(Curr_S
, Encl_S
);
8442 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8443 -- is properly released upon exiting the said scope.
8445 if Uses_Sec_Stack
(Curr_S
) then
8446 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8448 -- Do not mark a function that returns on the secondary stack as the
8449 -- reclamation is done by the caller.
8451 if Ekind
(Curr_S
) = E_Function
8452 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8456 -- Otherwise mark the enclosing dynamic scope
8459 Set_Uses_Sec_Stack
(Curr_S
);
8460 Check_Restriction
(No_Secondary_Stack
, N
);
8463 end Wrap_Transient_Declaration
;
8465 -------------------------------
8466 -- Wrap_Transient_Expression --
8467 -------------------------------
8469 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8470 Loc
: constant Source_Ptr
:= Sloc
(N
);
8471 Expr
: Node_Id
:= Relocate_Node
(N
);
8472 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8473 Typ
: constant Entity_Id
:= Etype
(N
);
8480 -- M : constant Mark_Id := SS_Mark;
8481 -- procedure Finalizer is ... (See Build_Finalizer)
8484 -- Temp := <Expr>; -- general case
8485 -- Temp := (if <Expr> then True else False); -- boolean case
8491 -- A special case is made for Boolean expressions so that the back-end
8492 -- knows to generate a conditional branch instruction, if running with
8493 -- -fpreserve-control-flow. This ensures that a control flow change
8494 -- signalling the decision outcome occurs before the cleanup actions.
8496 if Opt
.Suppress_Control_Flow_Optimizations
8497 and then Is_Boolean_Type
(Typ
)
8500 Make_If_Expression
(Loc
,
8501 Expressions
=> New_List
(
8503 New_Occurrence_Of
(Standard_True
, Loc
),
8504 New_Occurrence_Of
(Standard_False
, Loc
)));
8507 Insert_Actions
(N
, New_List
(
8508 Make_Object_Declaration
(Loc
,
8509 Defining_Identifier
=> Temp
,
8510 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8512 Make_Transient_Block
(Loc
,
8514 Make_Assignment_Statement
(Loc
,
8515 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8516 Expression
=> Expr
),
8517 Par
=> Parent
(N
))));
8519 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8520 Analyze_And_Resolve
(N
, Typ
);
8521 end Wrap_Transient_Expression
;
8523 ------------------------------
8524 -- Wrap_Transient_Statement --
8525 ------------------------------
8527 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8528 Loc
: constant Source_Ptr
:= Sloc
(N
);
8529 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8534 -- M : constant Mark_Id := SS_Mark;
8535 -- procedure Finalizer is ... (See Build_Finalizer)
8545 Make_Transient_Block
(Loc
,
8547 Par
=> Parent
(N
)));
8549 -- With the scope stack back to normal, we can call analyze on the
8550 -- resulting block. At this point, the transient scope is being
8551 -- treated like a perfectly normal scope, so there is nothing
8552 -- special about it.
8554 -- Note: Wrap_Transient_Statement is called with the node already
8555 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8556 -- otherwise we would get a recursive processing of the node when
8557 -- we do this Analyze call.
8560 end Wrap_Transient_Statement
;