1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Disp
; use Exp_Disp
;
41 with Exp_Prag
; use Exp_Prag
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
46 with Nlists
; use Nlists
;
47 with Nmake
; use Nmake
;
49 with Output
; use Output
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
53 with Sinfo
; use Sinfo
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch3
; use Sem_Ch3
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Util
; use Sem_Util
;
61 with Snames
; use Snames
;
62 with Stand
; use Stand
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Uintp
; use Uintp
;
67 package body Exp_Ch7
is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
129 -- Locate a suitable context for arbitrary node N which may need to be
130 -- serviced by a transient scope. Return Empty if no suitable context is
133 procedure Insert_Actions_In_Scope_Around
136 Manage_SS
: Boolean);
137 -- Insert the before-actions kept in the scope stack before N, and the
138 -- after-actions after N, which must be a member of a list. If flag Clean
139 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
140 -- calls to mark and release the secondary stack.
142 function Make_Transient_Block
145 Par
: Node_Id
) return Node_Id
;
146 -- Action is a single statement or object declaration. Par is the proper
147 -- parent of the generated block. Create a transient block whose name is
148 -- the current scope and the only handled statement is Action. If Action
149 -- involves controlled objects or secondary stack usage, the corresponding
150 -- cleanup actions are performed at the end of the block.
152 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
153 -- Set the field Node_To_Be_Wrapped of the current scope
155 -- ??? The entire comment needs to be rewritten
156 -- ??? which entire comment?
158 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
159 -- Shared processing for Store_xxx_Actions_In_Scope
161 -----------------------------
162 -- Finalization Management --
163 -----------------------------
165 -- This part describe how Initialization/Adjustment/Finalization procedures
166 -- are generated and called. Two cases must be considered, types that are
167 -- Controlled (Is_Controlled flag set) and composite types that contain
168 -- controlled components (Has_Controlled_Component flag set). In the first
169 -- case the procedures to call are the user-defined primitive operations
170 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
171 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
172 -- of calling the former procedures on the controlled components.
174 -- For records with Has_Controlled_Component set, a hidden "controller"
175 -- component is inserted. This controller component contains its own
176 -- finalization list on which all controlled components are attached
177 -- creating an indirection on the upper-level Finalization list. This
178 -- technique facilitates the management of objects whose number of
179 -- controlled components changes during execution. This controller
180 -- component is itself controlled and is attached to the upper-level
181 -- finalization chain. Its adjust primitive is in charge of calling adjust
182 -- on the components and adjusting the finalization pointer to match their
183 -- new location (see a-finali.adb).
185 -- It is not possible to use a similar technique for arrays that have
186 -- Has_Controlled_Component set. In this case, deep procedures are
187 -- generated that call initialize/adjust/finalize + attachment or
188 -- detachment on the finalization list for all component.
190 -- Initialize calls: they are generated for declarations or dynamic
191 -- allocations of Controlled objects with no initial value. They are always
192 -- followed by an attachment to the current Finalization Chain. For the
193 -- dynamic allocation case this the chain attached to the scope of the
194 -- access type definition otherwise, this is the chain of the current
197 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
198 -- or dynamic allocations of Controlled objects with an initial value.
199 -- (2) after an assignment. In the first case they are followed by an
200 -- attachment to the final chain, in the second case they are not.
202 -- Finalization Calls: They are generated on (1) scope exit, (2)
203 -- assignments, (3) unchecked deallocations. In case (3) they have to
204 -- be detached from the final chain, in case (2) they must not and in
205 -- case (1) this is not important since we are exiting the scope anyway.
209 -- Type extensions will have a new record controller at each derivation
210 -- level containing controlled components. The record controller for
211 -- the parent/ancestor is attached to the finalization list of the
212 -- extension's record controller (i.e. the parent is like a component
213 -- of the extension).
215 -- For types that are both Is_Controlled and Has_Controlled_Components,
216 -- the record controller and the object itself are handled separately.
217 -- It could seem simpler to attach the object at the end of its record
218 -- controller but this would not tackle view conversions properly.
220 -- A classwide type can always potentially have controlled components
221 -- but the record controller of the corresponding actual type may not
222 -- be known at compile time so the dispatch table contains a special
223 -- field that allows computation of the offset of the record controller
224 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
226 -- Here is a simple example of the expansion of a controlled block :
230 -- Y : Controlled := Init;
236 -- Z : R := (C => X);
246 -- _L : System.FI.Finalizable_Ptr;
248 -- procedure _Clean is
251 -- System.FI.Finalize_List (_L);
259 -- Attach_To_Final_List (_L, Finalizable (X), 1);
260 -- at end: Abort_Undefer;
261 -- Y : Controlled := Init;
263 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
271 -- Deep_Initialize (W, _L, 1);
272 -- at end: Abort_Under;
273 -- Z : R := (C => X);
274 -- Deep_Adjust (Z, _L, 1);
278 -- Deep_Finalize (W, False);
279 -- <save W's final pointers>
281 -- <restore W's final pointers>
282 -- Deep_Adjust (W, _L, 0);
287 type Final_Primitives
is
288 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
289 -- This enumeration type is defined in order to ease sharing code for
290 -- building finalization procedures for composite types.
292 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
293 (Initialize_Case
=> Name_Initialize
,
294 Adjust_Case
=> Name_Adjust
,
295 Finalize_Case
=> Name_Finalize
,
296 Address_Case
=> Name_Finalize_Address
);
297 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
298 (Initialize_Case
=> TSS_Deep_Initialize
,
299 Adjust_Case
=> TSS_Deep_Adjust
,
300 Finalize_Case
=> TSS_Deep_Finalize
,
301 Address_Case
=> TSS_Finalize_Address
);
303 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
304 -- Determine whether access type Typ may have a finalization master
306 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
307 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
308 -- Has_Controlled_Component set and store them using the TSS mechanism.
310 function Build_Cleanup_Statements
312 Additional_Cleanup
: List_Id
) return List_Id
;
313 -- Create the cleanup calls for an asynchronous call block, task master,
314 -- protected subprogram body, task allocation block or task body, or
315 -- additional cleanup actions parked on a transient block. If the context
316 -- does not contain the above constructs, the routine returns an empty
319 procedure Build_Finalizer
321 Clean_Stmts
: List_Id
;
324 Defer_Abort
: Boolean;
325 Fin_Id
: out Entity_Id
);
326 -- N may denote an accept statement, block, entry body, package body,
327 -- package spec, protected body, subprogram body, or a task body. Create
328 -- a procedure which contains finalization calls for all controlled objects
329 -- declared in the declarative or statement region of N. The calls are
330 -- built in reverse order relative to the original declarations. In the
331 -- case of a task body, the routine delays the creation of the finalizer
332 -- until all statements have been moved to the task body procedure.
333 -- Clean_Stmts may contain additional context-dependent code used to abort
334 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
335 -- Mark_Id is the secondary stack used in the current context or Empty if
336 -- missing. Top_Decls is the list on which the declaration of the finalizer
337 -- is attached in the non-package case. Defer_Abort indicates that the
338 -- statements passed in perform actions that require abort to be deferred,
339 -- such as for task termination. Fin_Id is the finalizer declaration
342 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
343 -- N is a construct which contains a handled sequence of statements, Fin_Id
344 -- is the entity of a finalizer. Create an At_End handler which covers the
345 -- statements of N and calls Fin_Id. If the handled statement sequence has
346 -- an exception handler, the statements will be wrapped in a block to avoid
347 -- unwanted interaction with the new At_End handler.
349 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
350 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
351 -- Has_Component_Component set and store them using the TSS mechanism.
353 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
354 -- The statement part of a package body that is a compilation unit may
355 -- contain blocks that declare local subprograms. In Subprogram_Unnesting
356 -- Mode such subprograms must be handled as nested inside the (implicit)
357 -- elaboration procedure that executes that statement part. To handle
358 -- properly uplevel references we construct that subprogram explicitly,
359 -- to contain blocks and inner subprograms, The statement part becomes
360 -- a call to this subprogram. This is only done if blocks are present
361 -- in the statement list of the body.
363 procedure Check_Visibly_Controlled
364 (Prim
: Final_Primitives
;
366 E
: in out Entity_Id
;
367 Cref
: in out Node_Id
);
368 -- The controlled operation declared for a derived type may not be
369 -- overriding, if the controlled operations of the parent type are hidden,
370 -- for example when the parent is a private type whose full view is
371 -- controlled. For other primitive operations we modify the name of the
372 -- operation to indicate that it is not overriding, but this is not
373 -- possible for Initialize, etc. because they have to be retrievable by
374 -- name. Before generating the proper call to one of these operations we
375 -- check whether Typ is known to be controlled at the point of definition.
376 -- If it is not then we must retrieve the hidden operation of the parent
377 -- and use it instead. This is one case that might be solved more cleanly
378 -- once Overriding pragmas or declarations are in place.
380 function Convert_View
383 Ind
: Pos
:= 1) return Node_Id
;
384 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
385 -- argument being passed to it. Ind indicates which formal of procedure
386 -- Proc we are trying to match. This function will, if necessary, generate
387 -- a conversion between the partial and full view of Arg to match the type
388 -- of the formal of Proc, or force a conversion to the class-wide type in
389 -- the case where the operation is abstract.
391 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
392 -- Given an arbitrary entity, traverse the scope chain looking for the
393 -- first enclosing function. Return Empty if no function was found.
399 Skip_Self
: Boolean := False) return Node_Id
;
400 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
401 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
402 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
403 -- action has an effect on the components only (if any).
405 function Make_Deep_Proc
406 (Prim
: Final_Primitives
;
408 Stmts
: List_Id
) return Node_Id
;
409 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
410 -- Deep_Finalize procedures according to the first parameter, these
411 -- procedures operate on the type Typ. The Stmts parameter gives the body
414 function Make_Deep_Array_Body
415 (Prim
: Final_Primitives
;
416 Typ
: Entity_Id
) return List_Id
;
417 -- This function generates the list of statements for implementing
418 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
419 -- the first parameter, these procedures operate on the array type Typ.
421 function Make_Deep_Record_Body
422 (Prim
: Final_Primitives
;
424 Is_Local
: Boolean := False) return List_Id
;
425 -- This function generates the list of statements for implementing
426 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
427 -- the first parameter, these procedures operate on the record type Typ.
428 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
429 -- whether the inner logic should be dictated by state counters.
431 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
432 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
433 -- Make_Deep_Record_Body. Generate the following statements:
436 -- type Acc_Typ is access all Typ;
437 -- for Acc_Typ'Storage_Size use 0;
439 -- [Deep_]Finalize (Acc_Typ (V).all);
442 --------------------------------
443 -- Allows_Finalization_Master --
444 --------------------------------
446 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
447 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
448 -- Determine whether entity E is inside a wrapper package created for
449 -- an instance of Ada.Unchecked_Deallocation.
451 ------------------------------
452 -- In_Deallocation_Instance --
453 ------------------------------
455 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
456 Pkg
: constant Entity_Id
:= Scope
(E
);
457 Par
: Node_Id
:= Empty
;
460 if Ekind
(Pkg
) = E_Package
461 and then Present
(Related_Instance
(Pkg
))
462 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
464 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
468 and then Chars
(Par
) = Name_Unchecked_Deallocation
469 and then Chars
(Scope
(Par
)) = Name_Ada
470 and then Scope
(Scope
(Par
)) = Standard_Standard
;
474 end In_Deallocation_Instance
;
478 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
479 Ptr_Typ
: constant Entity_Id
:=
480 Root_Type_Of_Full_View
(Base_Type
(Typ
));
482 -- Start of processing for Allows_Finalization_Master
485 -- Certain run-time configurations and targets do not provide support
486 -- for controlled types and therefore do not need masters.
488 if Restriction_Active
(No_Finalization
) then
491 -- Do not consider C and C++ types since it is assumed that the non-Ada
492 -- side will handle their cleanup.
494 elsif Convention
(Desig_Typ
) = Convention_C
495 or else Convention
(Desig_Typ
) = Convention_CPP
499 -- Do not consider an access type that returns on the secondary stack
501 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
502 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
506 -- Do not consider an access type that can never allocate an object
508 elsif No_Pool_Assigned
(Ptr_Typ
) then
511 -- Do not consider an access type coming from an Unchecked_Deallocation
512 -- instance. Even though the designated type may be controlled, the
513 -- access type will never participate in any allocations.
515 elsif In_Deallocation_Instance
(Ptr_Typ
) then
518 -- Do not consider a non-library access type when No_Nested_Finalization
519 -- is in effect since finalization masters are controlled objects and if
520 -- created will violate the restriction.
522 elsif Restriction_Active
(No_Nested_Finalization
)
523 and then not Is_Library_Level_Entity
(Ptr_Typ
)
527 -- Do not consider an access type subject to pragma No_Heap_Finalization
528 -- because objects allocated through such a type are not to be finalized
529 -- when the access type goes out of scope.
531 elsif No_Heap_Finalization
(Ptr_Typ
) then
534 -- Do not create finalization masters in GNATprove mode because this
535 -- causes unwanted extra expansion. A compilation in this mode must
536 -- keep the tree as close as possible to the original sources.
538 elsif GNATprove_Mode
then
541 -- Otherwise the access type may use a finalization master
546 end Allows_Finalization_Master
;
548 ----------------------------
549 -- Build_Anonymous_Master --
550 ----------------------------
552 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
553 function Create_Anonymous_Master
554 (Desig_Typ
: Entity_Id
;
556 Unit_Decl
: Node_Id
) return Entity_Id
;
557 -- Create a new anonymous master for access type Ptr_Typ with designated
558 -- type Desig_Typ. The declaration of the master and its initialization
559 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
560 -- the entity of Unit_Decl.
562 function Current_Anonymous_Master
563 (Desig_Typ
: Entity_Id
;
564 Unit_Id
: Entity_Id
) return Entity_Id
;
565 -- Find an anonymous master declared within unit Unit_Id which services
566 -- designated type Desig_Typ. If there is no such master, return Empty.
568 -----------------------------
569 -- Create_Anonymous_Master --
570 -----------------------------
572 function Create_Anonymous_Master
573 (Desig_Typ
: Entity_Id
;
575 Unit_Decl
: Node_Id
) return Entity_Id
577 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
588 -- <FM_Id> : Finalization_Master;
590 FM_Id
:= Make_Temporary
(Loc
, 'A');
593 Make_Object_Declaration
(Loc
,
594 Defining_Identifier
=> FM_Id
,
596 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
600 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
603 Make_Procedure_Call_Statement
(Loc
,
605 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
606 Parameter_Associations
=> New_List
(
607 New_Occurrence_Of
(FM_Id
, Loc
),
608 Make_Attribute_Reference
(Loc
,
610 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
611 Attribute_Name
=> Name_Unrestricted_Access
)));
613 -- Find the declarative list of the unit
615 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
616 Unit_Spec
:= Specification
(Unit_Decl
);
617 Decls
:= Visible_Declarations
(Unit_Spec
);
621 Set_Visible_Declarations
(Unit_Spec
, Decls
);
624 -- Package body or subprogram case
626 -- ??? A subprogram spec or body that acts as a compilation unit may
627 -- contain a formal parameter of an anonymous access-to-controlled
628 -- type initialized by an allocator.
630 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
632 -- There is no suitable place to create the master as the subprogram
633 -- is not in a declarative list.
636 Decls
:= Declarations
(Unit_Decl
);
640 Set_Declarations
(Unit_Decl
, Decls
);
644 Prepend_To
(Decls
, FM_Init
);
645 Prepend_To
(Decls
, FM_Decl
);
647 -- Use the scope of the unit when analyzing the declaration of the
648 -- master and its initialization actions.
650 Push_Scope
(Unit_Id
);
655 -- Mark the master as servicing this specific designated type
657 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
659 -- Include the anonymous master in the list of existing masters which
660 -- appear in this unit. This effectively creates a mapping between a
661 -- master and a designated type which in turn allows for the reuse of
662 -- masters on a per-unit basis.
664 All_FMs
:= Anonymous_Masters
(Unit_Id
);
667 All_FMs
:= New_Elmt_List
;
668 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
671 Prepend_Elmt
(FM_Id
, All_FMs
);
674 end Create_Anonymous_Master
;
676 ------------------------------
677 -- Current_Anonymous_Master --
678 ------------------------------
680 function Current_Anonymous_Master
681 (Desig_Typ
: Entity_Id
;
682 Unit_Id
: Entity_Id
) return Entity_Id
684 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
689 -- Inspect the list of anonymous masters declared within the unit
690 -- looking for an existing master which services the same designated
693 if Present
(All_FMs
) then
694 FM_Elmt
:= First_Elmt
(All_FMs
);
695 while Present
(FM_Elmt
) loop
696 FM_Id
:= Node
(FM_Elmt
);
698 -- The currect master services the same designated type. As a
699 -- result the master can be reused and associated with another
700 -- anonymous access-to-controlled type.
702 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
711 end Current_Anonymous_Master
;
715 Desig_Typ
: Entity_Id
;
717 Priv_View
: Entity_Id
;
721 -- Start of processing for Build_Anonymous_Master
724 -- Nothing to do if the circumstances do not allow for a finalization
727 if not Allows_Finalization_Master
(Ptr_Typ
) then
731 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
732 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
734 -- The compilation unit is a package instantiation. In this case the
735 -- anonymous master is associated with the package spec as both the
736 -- spec and body appear at the same level.
738 if Nkind
(Unit_Decl
) = N_Package_Body
739 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
741 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
742 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
745 -- Use the initial declaration of the designated type when it denotes
746 -- the full view of an incomplete or private type. This ensures that
747 -- types with one and two views are treated the same.
749 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
750 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
752 if Present
(Priv_View
) then
753 Desig_Typ
:= Priv_View
;
756 -- Determine whether the current semantic unit already has an anonymous
757 -- master which services the designated type.
759 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
761 -- If this is not the case, create a new master
764 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
767 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
768 end Build_Anonymous_Master
;
770 ----------------------------
771 -- Build_Array_Deep_Procs --
772 ----------------------------
774 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
778 (Prim
=> Initialize_Case
,
780 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
782 if not Is_Limited_View
(Typ
) then
785 (Prim
=> Adjust_Case
,
787 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
790 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
791 -- suppressed since these routine will not be used.
793 if not Restriction_Active
(No_Finalization
) then
796 (Prim
=> Finalize_Case
,
798 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
800 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
802 if not CodePeer_Mode
then
805 (Prim
=> Address_Case
,
807 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
810 end Build_Array_Deep_Procs
;
812 ------------------------------
813 -- Build_Cleanup_Statements --
814 ------------------------------
816 function Build_Cleanup_Statements
818 Additional_Cleanup
: List_Id
) return List_Id
820 Is_Asynchronous_Call
: constant Boolean :=
821 Nkind
(N
) = N_Block_Statement
822 and then Is_Asynchronous_Call_Block
(N
);
823 Is_Master
: constant Boolean :=
824 Nkind
(N
) /= N_Entry_Body
825 and then Is_Task_Master
(N
);
826 Is_Protected_Body
: constant Boolean :=
827 Nkind
(N
) = N_Subprogram_Body
828 and then Is_Protected_Subprogram_Body
(N
);
829 Is_Task_Allocation
: constant Boolean :=
830 Nkind
(N
) = N_Block_Statement
831 and then Is_Task_Allocation_Block
(N
);
832 Is_Task_Body
: constant Boolean :=
833 Nkind
(Original_Node
(N
)) = N_Task_Body
;
835 Loc
: constant Source_Ptr
:= Sloc
(N
);
836 Stmts
: constant List_Id
:= New_List
;
840 if Restricted_Profile
then
842 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
844 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
848 if Restriction_Active
(No_Task_Hierarchy
) = False then
849 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
852 -- Add statements to unlock the protected object parameter and to
853 -- undefer abort. If the context is a protected procedure and the object
854 -- has entries, call the entry service routine.
856 -- NOTE: The generated code references _object, a parameter to the
859 elsif Is_Protected_Body
then
861 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
862 Conc_Typ
: Entity_Id
;
864 Param_Typ
: Entity_Id
;
867 -- Find the _object parameter representing the protected object
869 Param
:= First
(Parameter_Specifications
(Spec
));
871 Param_Typ
:= Etype
(Parameter_Type
(Param
));
873 if Ekind
(Param_Typ
) = E_Record_Type
then
874 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
877 exit when No
(Param
) or else Present
(Conc_Typ
);
881 pragma Assert
(Present
(Param
));
883 -- Historical note: In earlier versions of GNAT, there was code
884 -- at this point to generate stuff to service entry queues. It is
885 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
887 Build_Protected_Subprogram_Call_Cleanup
888 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
891 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
892 -- tasks. Other unactivated tasks are completed by Complete_Task or
895 -- NOTE: The generated code references _chain, a local object
897 elsif Is_Task_Allocation
then
900 -- Expunge_Unactivated_Tasks (_chain);
902 -- where _chain is the list of tasks created by the allocator but not
903 -- yet activated. This list will be empty unless the block completes
907 Make_Procedure_Call_Statement
(Loc
,
910 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
911 Parameter_Associations
=> New_List
(
912 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
914 -- Attempt to cancel an asynchronous entry call whenever the block which
915 -- contains the abortable part is exited.
917 -- NOTE: The generated code references Cnn, a local object
919 elsif Is_Asynchronous_Call
then
921 Cancel_Param
: constant Entity_Id
:=
922 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
925 -- If it is of type Communication_Block, this must be a protected
926 -- entry call. Generate:
928 -- if Enqueued (Cancel_Param) then
929 -- Cancel_Protected_Entry_Call (Cancel_Param);
932 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
934 Make_If_Statement
(Loc
,
936 Make_Function_Call
(Loc
,
938 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
939 Parameter_Associations
=> New_List
(
940 New_Occurrence_Of
(Cancel_Param
, Loc
))),
942 Then_Statements
=> New_List
(
943 Make_Procedure_Call_Statement
(Loc
,
946 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
947 Parameter_Associations
=> New_List
(
948 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
950 -- Asynchronous delay, generate:
951 -- Cancel_Async_Delay (Cancel_Param);
953 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
955 Make_Procedure_Call_Statement
(Loc
,
957 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
958 Parameter_Associations
=> New_List
(
959 Make_Attribute_Reference
(Loc
,
961 New_Occurrence_Of
(Cancel_Param
, Loc
),
962 Attribute_Name
=> Name_Unchecked_Access
))));
964 -- Task entry call, generate:
965 -- Cancel_Task_Entry_Call (Cancel_Param);
969 Make_Procedure_Call_Statement
(Loc
,
971 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
972 Parameter_Associations
=> New_List
(
973 New_Occurrence_Of
(Cancel_Param
, Loc
))));
978 Append_List_To
(Stmts
, Additional_Cleanup
);
980 end Build_Cleanup_Statements
;
982 -----------------------------
983 -- Build_Controlling_Procs --
984 -----------------------------
986 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
988 if Is_Array_Type
(Typ
) then
989 Build_Array_Deep_Procs
(Typ
);
990 else pragma Assert
(Is_Record_Type
(Typ
));
991 Build_Record_Deep_Procs
(Typ
);
993 end Build_Controlling_Procs
;
995 -----------------------------
996 -- Build_Exception_Handler --
997 -----------------------------
999 function Build_Exception_Handler
1000 (Data
: Finalization_Exception_Data
;
1001 For_Library
: Boolean := False) return Node_Id
1004 Proc_To_Call
: Entity_Id
;
1009 pragma Assert
(Present
(Data
.Raised_Id
));
1011 if Exception_Extra_Info
1012 or else (For_Library
and not Restricted_Profile
)
1014 if Exception_Extra_Info
then
1018 -- Get_Current_Excep.all
1021 Make_Function_Call
(Data
.Loc
,
1023 Make_Explicit_Dereference
(Data
.Loc
,
1026 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1033 Except
:= Make_Null
(Data
.Loc
);
1036 if For_Library
and then not Restricted_Profile
then
1037 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1038 Actuals
:= New_List
(Except
);
1041 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1043 -- The dereference occurs only when Exception_Extra_Info is true,
1044 -- and therefore Except is not null.
1048 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1049 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1055 -- if not Raised_Id then
1056 -- Raised_Id := True;
1058 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1060 -- Save_Library_Occurrence (Get_Current_Excep.all);
1065 Make_If_Statement
(Data
.Loc
,
1067 Make_Op_Not
(Data
.Loc
,
1068 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1070 Then_Statements
=> New_List
(
1071 Make_Assignment_Statement
(Data
.Loc
,
1072 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1073 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1075 Make_Procedure_Call_Statement
(Data
.Loc
,
1077 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1078 Parameter_Associations
=> Actuals
))));
1083 -- Raised_Id := True;
1086 Make_Assignment_Statement
(Data
.Loc
,
1087 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1088 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1096 Make_Exception_Handler
(Data
.Loc
,
1097 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1098 Statements
=> Stmts
);
1099 end Build_Exception_Handler
;
1101 -------------------------------
1102 -- Build_Finalization_Master --
1103 -------------------------------
1105 procedure Build_Finalization_Master
1107 For_Lib_Level
: Boolean := False;
1108 For_Private
: Boolean := False;
1109 Context_Scope
: Entity_Id
:= Empty
;
1110 Insertion_Node
: Node_Id
:= Empty
)
1112 procedure Add_Pending_Access_Type
1114 Ptr_Typ
: Entity_Id
);
1115 -- Add access type Ptr_Typ to the pending access type list for type Typ
1117 -----------------------------
1118 -- Add_Pending_Access_Type --
1119 -----------------------------
1121 procedure Add_Pending_Access_Type
1123 Ptr_Typ
: Entity_Id
)
1128 if Present
(Pending_Access_Types
(Typ
)) then
1129 List
:= Pending_Access_Types
(Typ
);
1131 List
:= New_Elmt_List
;
1132 Set_Pending_Access_Types
(Typ
, List
);
1135 Prepend_Elmt
(Ptr_Typ
, List
);
1136 end Add_Pending_Access_Type
;
1140 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1142 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1143 -- A finalization master created for a named access type is associated
1144 -- with the full view (if applicable) as a consequence of freezing. The
1145 -- full view criteria does not apply to anonymous access types because
1146 -- those cannot have a private and a full view.
1148 -- Start of processing for Build_Finalization_Master
1151 -- Nothing to do if the circumstances do not allow for a finalization
1154 if not Allows_Finalization_Master
(Typ
) then
1157 -- Various machinery such as freezing may have already created a
1158 -- finalization master.
1160 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1165 Actions
: constant List_Id
:= New_List
;
1166 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1167 Fin_Mas_Id
: Entity_Id
;
1168 Pool_Id
: Entity_Id
;
1171 -- Source access types use fixed master names since the master is
1172 -- inserted in the same source unit only once. The only exception to
1173 -- this are instances using the same access type as generic actual.
1175 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1177 Make_Defining_Identifier
(Loc
,
1178 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1180 -- Internally generated access types use temporaries as their names
1181 -- due to possible collision with identical names coming from other
1185 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1188 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1191 -- <Ptr_Typ>FM : aliased Finalization_Master;
1194 Make_Object_Declaration
(Loc
,
1195 Defining_Identifier
=> Fin_Mas_Id
,
1196 Aliased_Present
=> True,
1197 Object_Definition
=>
1198 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1200 -- Set the associated pool and primitive Finalize_Address of the new
1201 -- finalization master.
1203 -- The access type has a user-defined storage pool, use it
1205 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1206 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1208 -- Otherwise the default choice is the global storage pool
1211 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1212 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1216 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1219 Make_Procedure_Call_Statement
(Loc
,
1221 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1222 Parameter_Associations
=> New_List
(
1223 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1224 Make_Attribute_Reference
(Loc
,
1225 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1226 Attribute_Name
=> Name_Unrestricted_Access
))));
1228 -- Finalize_Address is not generated in CodePeer mode because the
1229 -- body contains address arithmetic. Skip this step.
1231 if CodePeer_Mode
then
1234 -- Associate the Finalize_Address primitive of the designated type
1235 -- with the finalization master of the access type. The designated
1236 -- type must be forzen as Finalize_Address is generated when the
1237 -- freeze node is expanded.
1239 elsif Is_Frozen
(Desig_Typ
)
1240 and then Present
(Finalize_Address
(Desig_Typ
))
1242 -- The finalization master of an anonymous access type may need
1243 -- to be inserted in a specific place in the tree. For instance:
1247 -- <finalization master of "access Comp_Typ">
1249 -- type Rec_Typ is record
1250 -- Comp : access Comp_Typ;
1253 -- <freeze node for Comp_Typ>
1254 -- <freeze node for Rec_Typ>
1256 -- Due to this oddity, the anonymous access type is stored for
1257 -- later processing (see below).
1259 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1262 -- Set_Finalize_Address
1263 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1266 Make_Set_Finalize_Address_Call
1268 Ptr_Typ
=> Ptr_Typ
));
1270 -- Otherwise the designated type is either anonymous access or a
1271 -- Taft-amendment type and has not been frozen. Store the access
1272 -- type for later processing (see Freeze_Type).
1275 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1278 -- A finalization master created for an access designating a type
1279 -- with private components is inserted before a context-dependent
1284 -- At this point both the scope of the context and the insertion
1285 -- mode must be known.
1287 pragma Assert
(Present
(Context_Scope
));
1288 pragma Assert
(Present
(Insertion_Node
));
1290 Push_Scope
(Context_Scope
);
1292 -- Treat use clauses as declarations and insert directly in front
1295 if Nkind_In
(Insertion_Node
, N_Use_Package_Clause
,
1298 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1300 Insert_Actions
(Insertion_Node
, Actions
);
1305 -- The finalization master belongs to an access result type related
1306 -- to a build-in-place function call used to initialize a library
1307 -- level object. The master must be inserted in front of the access
1308 -- result type declaration denoted by Insertion_Node.
1310 elsif For_Lib_Level
then
1311 pragma Assert
(Present
(Insertion_Node
));
1312 Insert_Actions
(Insertion_Node
, Actions
);
1314 -- Otherwise the finalization master and its initialization become a
1315 -- part of the freeze node.
1318 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1321 end Build_Finalization_Master
;
1323 ---------------------
1324 -- Build_Finalizer --
1325 ---------------------
1327 procedure Build_Finalizer
1329 Clean_Stmts
: List_Id
;
1330 Mark_Id
: Entity_Id
;
1331 Top_Decls
: List_Id
;
1332 Defer_Abort
: Boolean;
1333 Fin_Id
: out Entity_Id
)
1335 Acts_As_Clean
: constant Boolean :=
1338 (Present
(Clean_Stmts
)
1339 and then Is_Non_Empty_List
(Clean_Stmts
));
1340 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
1341 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1342 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1343 For_Package
: constant Boolean :=
1344 For_Package_Body
or else For_Package_Spec
;
1345 Loc
: constant Source_Ptr
:= Sloc
(N
);
1347 -- NOTE: Local variable declarations are conservative and do not create
1348 -- structures right from the start. Entities and lists are created once
1349 -- it has been established that N has at least one controlled object.
1351 Components_Built
: Boolean := False;
1352 -- A flag used to avoid double initialization of entities and lists. If
1353 -- the flag is set then the following variables have been initialized:
1359 Counter_Id
: Entity_Id
:= Empty
;
1360 Counter_Val
: Nat
:= 0;
1361 -- Name and value of the state counter
1363 Decls
: List_Id
:= No_List
;
1364 -- Declarative region of N (if available). If N is a package declaration
1365 -- Decls denotes the visible declarations.
1367 Finalizer_Data
: Finalization_Exception_Data
;
1368 -- Data for the exception
1370 Finalizer_Decls
: List_Id
:= No_List
;
1371 -- Local variable declarations. This list holds the label declarations
1372 -- of all jump block alternatives as well as the declaration of the
1373 -- local exception occurrence and the raised flag:
1374 -- E : Exception_Occurrence;
1375 -- Raised : Boolean := False;
1376 -- L<counter value> : label;
1378 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1379 -- Insertion point for the finalizer body. Depending on the context
1380 -- (Nkind of N) and the individual grouping of controlled objects, this
1381 -- node may denote a package declaration or body, package instantiation,
1382 -- block statement or a counter update statement.
1384 Finalizer_Stmts
: List_Id
:= No_List
;
1385 -- The statement list of the finalizer body. It contains the following:
1387 -- Abort_Defer; -- Added if abort is allowed
1388 -- <call to Prev_At_End> -- Added if exists
1389 -- <cleanup statements> -- Added if Acts_As_Clean
1390 -- <jump block> -- Added if Has_Ctrl_Objs
1391 -- <finalization statements> -- Added if Has_Ctrl_Objs
1392 -- <stack release> -- Added if Mark_Id exists
1393 -- Abort_Undefer; -- Added if abort is allowed
1395 Has_Ctrl_Objs
: Boolean := False;
1396 -- A general flag which denotes whether N has at least one controlled
1399 Has_Tagged_Types
: Boolean := False;
1400 -- A general flag which indicates whether N has at least one library-
1401 -- level tagged type declaration.
1403 HSS
: Node_Id
:= Empty
;
1404 -- The sequence of statements of N (if available)
1406 Jump_Alts
: List_Id
:= No_List
;
1407 -- Jump block alternatives. Depending on the value of the state counter,
1408 -- the control flow jumps to a sequence of finalization statements. This
1409 -- list contains the following:
1411 -- when <counter value> =>
1412 -- goto L<counter value>;
1414 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1415 -- Specific point in the finalizer statements where the jump block is
1418 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1419 -- The last controlled construct encountered when processing the top
1420 -- level lists of N. This can be a nested package, an instantiation or
1421 -- an object declaration.
1423 Prev_At_End
: Entity_Id
:= Empty
;
1424 -- The previous at end procedure of the handled statements block of N
1426 Priv_Decls
: List_Id
:= No_List
;
1427 -- The private declarations of N if N is a package declaration
1429 Spec_Id
: Entity_Id
:= Empty
;
1430 Spec_Decls
: List_Id
:= Top_Decls
;
1431 Stmts
: List_Id
:= No_List
;
1433 Tagged_Type_Stmts
: List_Id
:= No_List
;
1434 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1435 -- tagged types found in N.
1437 -----------------------
1438 -- Local subprograms --
1439 -----------------------
1441 procedure Build_Components
;
1442 -- Create all entites and initialize all lists used in the creation of
1445 procedure Create_Finalizer
;
1446 -- Create the spec and body of the finalizer and insert them in the
1447 -- proper place in the tree depending on the context.
1449 procedure Process_Declarations
1451 Preprocess
: Boolean := False;
1452 Top_Level
: Boolean := False);
1453 -- Inspect a list of declarations or statements which may contain
1454 -- objects that need finalization. When flag Preprocess is set, the
1455 -- routine will simply count the total number of controlled objects in
1456 -- Decls. Flag Top_Level denotes whether the processing is done for
1457 -- objects in nested package declarations or instances.
1459 procedure Process_Object_Declaration
1461 Has_No_Init
: Boolean := False;
1462 Is_Protected
: Boolean := False);
1463 -- Generate all the machinery associated with the finalization of a
1464 -- single object. Flag Has_No_Init is used to denote certain contexts
1465 -- where Decl does not have initialization call(s). Flag Is_Protected
1466 -- is set when Decl denotes a simple protected object.
1468 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1469 -- Generate all the code necessary to unregister the external tag of a
1472 ----------------------
1473 -- Build_Components --
1474 ----------------------
1476 procedure Build_Components
is
1477 Counter_Decl
: Node_Id
;
1478 Counter_Typ
: Entity_Id
;
1479 Counter_Typ_Decl
: Node_Id
;
1482 pragma Assert
(Present
(Decls
));
1484 -- This routine might be invoked several times when dealing with
1485 -- constructs that have two lists (either two declarative regions
1486 -- or declarations and statements). Avoid double initialization.
1488 if Components_Built
then
1492 Components_Built
:= True;
1494 if Has_Ctrl_Objs
then
1496 -- Create entities for the counter, its type, the local exception
1497 -- and the raised flag.
1499 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1500 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1502 Finalizer_Decls
:= New_List
;
1504 Build_Object_Declarations
1505 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1507 -- Since the total number of controlled objects is always known,
1508 -- build a subtype of Natural with precise bounds. This allows
1509 -- the backend to optimize the case statement. Generate:
1511 -- subtype Tnn is Natural range 0 .. Counter_Val;
1514 Make_Subtype_Declaration
(Loc
,
1515 Defining_Identifier
=> Counter_Typ
,
1516 Subtype_Indication
=>
1517 Make_Subtype_Indication
(Loc
,
1518 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1520 Make_Range_Constraint
(Loc
,
1524 Make_Integer_Literal
(Loc
, Uint_0
),
1526 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1528 -- Generate the declaration of the counter itself:
1530 -- Counter : Integer := 0;
1533 Make_Object_Declaration
(Loc
,
1534 Defining_Identifier
=> Counter_Id
,
1535 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1536 Expression
=> Make_Integer_Literal
(Loc
, 0));
1538 -- Set the type of the counter explicitly to prevent errors when
1539 -- examining object declarations later on.
1541 Set_Etype
(Counter_Id
, Counter_Typ
);
1543 -- The counter and its type are inserted before the source
1544 -- declarations of N.
1546 Prepend_To
(Decls
, Counter_Decl
);
1547 Prepend_To
(Decls
, Counter_Typ_Decl
);
1549 -- The counter and its associated type must be manually analyzed
1550 -- since N has already been analyzed. Use the scope of the spec
1551 -- when inserting in a package.
1554 Push_Scope
(Spec_Id
);
1555 Analyze
(Counter_Typ_Decl
);
1556 Analyze
(Counter_Decl
);
1560 Analyze
(Counter_Typ_Decl
);
1561 Analyze
(Counter_Decl
);
1564 Jump_Alts
:= New_List
;
1567 -- If the context requires additional cleanup, the finalization
1568 -- machinery is added after the cleanup code.
1570 if Acts_As_Clean
then
1571 Finalizer_Stmts
:= Clean_Stmts
;
1572 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1574 Finalizer_Stmts
:= New_List
;
1577 if Has_Tagged_Types
then
1578 Tagged_Type_Stmts
:= New_List
;
1580 end Build_Components
;
1582 ----------------------
1583 -- Create_Finalizer --
1584 ----------------------
1586 procedure Create_Finalizer
is
1587 function New_Finalizer_Name
return Name_Id
;
1588 -- Create a fully qualified name of a package spec or body finalizer.
1589 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1591 ------------------------
1592 -- New_Finalizer_Name --
1593 ------------------------
1595 function New_Finalizer_Name
return Name_Id
is
1596 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1597 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1598 -- has a non-standard scope, process the scope first.
1600 ------------------------
1601 -- New_Finalizer_Name --
1602 ------------------------
1604 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1606 if Scope
(Id
) = Standard_Standard
then
1607 Get_Name_String
(Chars
(Id
));
1610 New_Finalizer_Name
(Scope
(Id
));
1611 Add_Str_To_Name_Buffer
("__");
1612 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1614 end New_Finalizer_Name
;
1616 -- Start of processing for New_Finalizer_Name
1619 -- Create the fully qualified name of the enclosing scope
1621 New_Finalizer_Name
(Spec_Id
);
1624 -- __finalize_[spec|body]
1626 Add_Str_To_Name_Buffer
("__finalize_");
1628 if For_Package_Spec
then
1629 Add_Str_To_Name_Buffer
("spec");
1631 Add_Str_To_Name_Buffer
("body");
1635 end New_Finalizer_Name
;
1639 Body_Id
: Entity_Id
;
1642 Jump_Block
: Node_Id
;
1644 Label_Id
: Entity_Id
;
1646 -- Start of processing for Create_Finalizer
1649 -- Step 1: Creation of the finalizer name
1651 -- Packages must use a distinct name for their finalizers since the
1652 -- binder will have to generate calls to them by name. The name is
1653 -- of the following form:
1655 -- xx__yy__finalize_[spec|body]
1658 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1659 Set_Has_Qualified_Name
(Fin_Id
);
1660 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1662 -- The default name is _finalizer
1666 Make_Defining_Identifier
(Loc
,
1667 Chars
=> New_External_Name
(Name_uFinalizer
));
1669 -- The visibility semantics of AT_END handlers force a strange
1670 -- separation of spec and body for stack-related finalizers:
1672 -- declare : Enclosing_Scope
1673 -- procedure _finalizer;
1675 -- <controlled objects>
1676 -- procedure _finalizer is
1682 -- Both spec and body are within the same construct and scope, but
1683 -- the body is part of the handled sequence of statements. This
1684 -- placement confuses the elaboration mechanism on targets where
1685 -- AT_END handlers are expanded into "when all others" handlers:
1688 -- when all others =>
1689 -- _finalizer; -- appears to require elab checks
1694 -- Since the compiler guarantees that the body of a _finalizer is
1695 -- always inserted in the same construct where the AT_END handler
1696 -- resides, there is no need for elaboration checks.
1698 Set_Kill_Elaboration_Checks
(Fin_Id
);
1700 -- Inlining the finalizer produces a substantial speedup at -O2.
1701 -- It is inlined by default at -O3. Either way, it is called
1702 -- exactly twice (once on the normal path, and once for
1703 -- exceptions/abort), so this won't bloat the code too much.
1705 Set_Is_Inlined
(Fin_Id
);
1708 -- Step 2: Creation of the finalizer specification
1711 -- procedure Fin_Id;
1714 Make_Subprogram_Declaration
(Loc
,
1716 Make_Procedure_Specification
(Loc
,
1717 Defining_Unit_Name
=> Fin_Id
));
1719 -- Step 3: Creation of the finalizer body
1721 if Has_Ctrl_Objs
then
1723 -- Add L0, the default destination to the jump block
1725 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1726 Set_Entity
(Label_Id
,
1727 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1728 Label
:= Make_Label
(Loc
, Label_Id
);
1733 Prepend_To
(Finalizer_Decls
,
1734 Make_Implicit_Label_Declaration
(Loc
,
1735 Defining_Identifier
=> Entity
(Label_Id
),
1736 Label_Construct
=> Label
));
1742 Append_To
(Jump_Alts
,
1743 Make_Case_Statement_Alternative
(Loc
,
1744 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1745 Statements
=> New_List
(
1746 Make_Goto_Statement
(Loc
,
1747 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1752 Append_To
(Finalizer_Stmts
, Label
);
1754 -- Create the jump block which controls the finalization flow
1755 -- depending on the value of the state counter.
1758 Make_Case_Statement
(Loc
,
1759 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1760 Alternatives
=> Jump_Alts
);
1762 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1763 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1765 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1769 -- Add the library-level tagged type unregistration machinery before
1770 -- the jump block circuitry. This ensures that external tags will be
1771 -- removed even if a finalization exception occurs at some point.
1773 if Has_Tagged_Types
then
1774 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1777 -- Add a call to the previous At_End handler if it exists. The call
1778 -- must always precede the jump block.
1780 if Present
(Prev_At_End
) then
1781 Prepend_To
(Finalizer_Stmts
,
1782 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1784 -- Clear the At_End handler since we have already generated the
1785 -- proper replacement call for it.
1787 Set_At_End_Proc
(HSS
, Empty
);
1790 -- Release the secondary stack
1792 if Present
(Mark_Id
) then
1794 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1797 -- If the context is a build-in-place function, the secondary
1798 -- stack must be released, unless the build-in-place function
1799 -- itself is returning on the secondary stack. Generate:
1801 -- if BIP_Alloc_Form /= Secondary_Stack then
1802 -- SS_Release (Mark_Id);
1805 -- Note that if the function returns on the secondary stack,
1806 -- then the responsibility of reclaiming the space is always
1807 -- left to the caller (recursively if needed).
1809 if Nkind
(N
) = N_Subprogram_Body
then
1811 Spec_Id
: constant Entity_Id
:=
1812 Unique_Defining_Entity
(N
);
1813 BIP_SS
: constant Boolean :=
1814 Is_Build_In_Place_Function
(Spec_Id
)
1815 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1819 Make_If_Statement
(Loc
,
1824 (Build_In_Place_Formal
1825 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1827 Make_Integer_Literal
(Loc
,
1829 (BIP_Allocation_Form
'Pos
1830 (Secondary_Stack
)))),
1832 Then_Statements
=> New_List
(Release
));
1837 Append_To
(Finalizer_Stmts
, Release
);
1841 -- Protect the statements with abort defer/undefer. This is only when
1842 -- aborts are allowed and the cleanup statements require deferral or
1843 -- there are controlled objects to be finalized. Note that the abort
1844 -- defer/undefer pair does not require an extra block because each
1845 -- finalization exception is caught in its corresponding finalization
1846 -- block. As a result, the call to Abort_Defer always takes place.
1848 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1849 Prepend_To
(Finalizer_Stmts
,
1850 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1852 Append_To
(Finalizer_Stmts
,
1853 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1856 -- The local exception does not need to be reraised for library-level
1857 -- finalizers. Note that this action must be carried out after object
1858 -- cleanup, secondary stack release, and abort undeferral. Generate:
1860 -- if Raised and then not Abort then
1861 -- Raise_From_Controlled_Operation (E);
1864 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1865 Append_To
(Finalizer_Stmts
,
1866 Build_Raise_Statement
(Finalizer_Data
));
1870 -- procedure Fin_Id is
1871 -- Abort : constant Boolean := Triggered_By_Abort;
1873 -- Abort : constant Boolean := False; -- no abort
1875 -- E : Exception_Occurrence; -- All added if flag
1876 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1882 -- Abort_Defer; -- Added if abort is allowed
1883 -- <call to Prev_At_End> -- Added if exists
1884 -- <cleanup statements> -- Added if Acts_As_Clean
1885 -- <jump block> -- Added if Has_Ctrl_Objs
1886 -- <finalization statements> -- Added if Has_Ctrl_Objs
1887 -- <stack release> -- Added if Mark_Id exists
1888 -- Abort_Undefer; -- Added if abort is allowed
1889 -- <exception propagation> -- Added if Has_Ctrl_Objs
1892 -- Create the body of the finalizer
1894 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1897 Set_Has_Qualified_Name
(Body_Id
);
1898 Set_Has_Fully_Qualified_Name
(Body_Id
);
1902 Make_Subprogram_Body
(Loc
,
1904 Make_Procedure_Specification
(Loc
,
1905 Defining_Unit_Name
=> Body_Id
),
1906 Declarations
=> Finalizer_Decls
,
1907 Handled_Statement_Sequence
=>
1908 Make_Handled_Sequence_Of_Statements
(Loc
,
1909 Statements
=> Finalizer_Stmts
));
1911 -- Step 4: Spec and body insertion, analysis
1915 -- If the package spec has private declarations, the finalizer
1916 -- body must be added to the end of the list in order to have
1917 -- visibility of all private controlled objects.
1919 if For_Package_Spec
then
1920 if Present
(Priv_Decls
) then
1921 Append_To
(Priv_Decls
, Fin_Spec
);
1922 Append_To
(Priv_Decls
, Fin_Body
);
1924 Append_To
(Decls
, Fin_Spec
);
1925 Append_To
(Decls
, Fin_Body
);
1928 -- For package bodies, both the finalizer spec and body are
1929 -- inserted at the end of the package declarations.
1932 Append_To
(Decls
, Fin_Spec
);
1933 Append_To
(Decls
, Fin_Body
);
1936 -- Push the name of the package
1938 Push_Scope
(Spec_Id
);
1946 -- Create the spec for the finalizer. The At_End handler must be
1947 -- able to call the body which resides in a nested structure.
1951 -- procedure Fin_Id; -- Spec
1953 -- <objects and possibly statements>
1954 -- procedure Fin_Id is ... -- Body
1957 -- Fin_Id; -- At_End handler
1960 pragma Assert
(Present
(Spec_Decls
));
1962 Append_To
(Spec_Decls
, Fin_Spec
);
1965 -- When the finalizer acts solely as a cleanup routine, the body
1966 -- is inserted right after the spec.
1968 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1969 Insert_After
(Fin_Spec
, Fin_Body
);
1971 -- In all other cases the body is inserted after either:
1973 -- 1) The counter update statement of the last controlled object
1974 -- 2) The last top level nested controlled package
1975 -- 3) The last top level controlled instantiation
1978 -- Manually freeze the spec. This is somewhat of a hack because
1979 -- a subprogram is frozen when its body is seen and the freeze
1980 -- node appears right before the body. However, in this case,
1981 -- the spec must be frozen earlier since the At_End handler
1982 -- must be able to call it.
1985 -- procedure Fin_Id; -- Spec
1986 -- [Fin_Id] -- Freeze node
1990 -- Fin_Id; -- At_End handler
1993 Ensure_Freeze_Node
(Fin_Id
);
1994 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1995 Set_Is_Frozen
(Fin_Id
);
1997 -- In the case where the last construct to contain a controlled
1998 -- object is either a nested package, an instantiation or a
1999 -- freeze node, the body must be inserted directly after the
2002 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
2004 N_Package_Declaration
,
2007 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2010 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2013 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2015 end Create_Finalizer
;
2017 --------------------------
2018 -- Process_Declarations --
2019 --------------------------
2021 procedure Process_Declarations
2023 Preprocess
: Boolean := False;
2024 Top_Level
: Boolean := False)
2029 Obj_Typ
: Entity_Id
;
2030 Pack_Id
: Entity_Id
;
2034 Old_Counter_Val
: Nat
;
2035 -- This variable is used to determine whether a nested package or
2036 -- instance contains at least one controlled object.
2038 procedure Processing_Actions
2039 (Has_No_Init
: Boolean := False;
2040 Is_Protected
: Boolean := False);
2041 -- Depending on the mode of operation of Process_Declarations, either
2042 -- increment the controlled object counter, set the controlled object
2043 -- flag and store the last top level construct or process the current
2044 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2045 -- the current declaration may not have initialization proc(s). Flag
2046 -- Is_Protected should be set when the current declaration denotes a
2047 -- simple protected object.
2049 ------------------------
2050 -- Processing_Actions --
2051 ------------------------
2053 procedure Processing_Actions
2054 (Has_No_Init
: Boolean := False;
2055 Is_Protected
: Boolean := False)
2058 -- Library-level tagged type
2060 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2062 Has_Tagged_Types
:= True;
2064 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2065 Last_Top_Level_Ctrl_Construct
:= Decl
;
2069 Process_Tagged_Type_Declaration
(Decl
);
2072 -- Controlled object declaration
2076 Counter_Val
:= Counter_Val
+ 1;
2077 Has_Ctrl_Objs
:= True;
2079 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2080 Last_Top_Level_Ctrl_Construct
:= Decl
;
2084 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2087 end Processing_Actions
;
2089 -- Start of processing for Process_Declarations
2092 if No
(Decls
) or else Is_Empty_List
(Decls
) then
2096 -- Process all declarations in reverse order
2098 Decl
:= Last_Non_Pragma
(Decls
);
2099 while Present
(Decl
) loop
2101 -- Library-level tagged types
2103 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2104 Typ
:= Defining_Identifier
(Decl
);
2106 -- Ignored Ghost types do not need any cleanup actions because
2107 -- they will not appear in the final tree.
2109 if Is_Ignored_Ghost_Entity
(Typ
) then
2112 elsif Is_Tagged_Type
(Typ
)
2113 and then Is_Library_Level_Entity
(Typ
)
2114 and then Convention
(Typ
) = Convention_Ada
2115 and then Present
(Access_Disp_Table
(Typ
))
2116 and then RTE_Available
(RE_Register_Tag
)
2117 and then not Is_Abstract_Type
(Typ
)
2118 and then not No_Run_Time_Mode
2123 -- Regular object declarations
2125 elsif Nkind
(Decl
) = N_Object_Declaration
then
2126 Obj_Id
:= Defining_Identifier
(Decl
);
2127 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2128 Expr
:= Expression
(Decl
);
2130 -- Bypass any form of processing for objects which have their
2131 -- finalization disabled. This applies only to objects at the
2134 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2137 -- Finalization of transient objects are treated separately in
2138 -- order to handle sensitive cases. These include:
2140 -- * Aggregate expansion
2141 -- * If, case, and expression with actions expansion
2142 -- * Transient scopes
2144 -- If one of those contexts has marked the transient object as
2145 -- ignored, do not generate finalization actions for it.
2147 elsif Is_Finalized_Transient
(Obj_Id
)
2148 or else Is_Ignored_Transient
(Obj_Id
)
2152 -- Ignored Ghost objects do not need any cleanup actions
2153 -- because they will not appear in the final tree.
2155 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2158 -- The object is of the form:
2159 -- Obj : [constant] Typ [:= Expr];
2161 -- Do not process tag-to-class-wide conversions because they do
2162 -- not yield an object. Do not process the incomplete view of a
2163 -- deferred constant. Note that an object initialized by means
2164 -- of a build-in-place function call may appear as a deferred
2165 -- constant after expansion activities. These kinds of objects
2166 -- must be finalized.
2168 elsif not Is_Imported
(Obj_Id
)
2169 and then Needs_Finalization
(Obj_Typ
)
2170 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2171 and then not (Ekind
(Obj_Id
) = E_Constant
2172 and then not Has_Completion
(Obj_Id
)
2173 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2177 -- The object is of the form:
2178 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2180 -- Obj : Access_Typ :=
2181 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2183 elsif Is_Access_Type
(Obj_Typ
)
2184 and then Needs_Finalization
2185 (Available_View
(Designated_Type
(Obj_Typ
)))
2186 and then Present
(Expr
)
2188 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2190 (Is_Non_BIP_Func_Call
(Expr
)
2191 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2193 Processing_Actions
(Has_No_Init
=> True);
2195 -- Processing for "hook" objects generated for transient
2196 -- objects declared inside an Expression_With_Actions.
2198 elsif Is_Access_Type
(Obj_Typ
)
2199 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2200 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2201 N_Object_Declaration
2203 Processing_Actions
(Has_No_Init
=> True);
2205 -- Process intermediate results of an if expression with one
2206 -- of the alternatives using a controlled function call.
2208 elsif Is_Access_Type
(Obj_Typ
)
2209 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2210 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2211 N_Defining_Identifier
2212 and then Present
(Expr
)
2213 and then Nkind
(Expr
) = N_Null
2215 Processing_Actions
(Has_No_Init
=> True);
2217 -- Simple protected objects which use type System.Tasking.
2218 -- Protected_Objects.Protection to manage their locks should
2219 -- be treated as controlled since they require manual cleanup.
2220 -- The only exception is illustrated in the following example:
2223 -- type Ctrl is new Controlled ...
2224 -- procedure Finalize (Obj : in out Ctrl);
2228 -- package body Pkg is
2229 -- protected Prot is
2230 -- procedure Do_Something (Obj : in out Ctrl);
2233 -- protected body Prot is
2234 -- procedure Do_Something (Obj : in out Ctrl) is ...
2237 -- procedure Finalize (Obj : in out Ctrl) is
2239 -- Prot.Do_Something (Obj);
2243 -- Since for the most part entities in package bodies depend on
2244 -- those in package specs, Prot's lock should be cleaned up
2245 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2246 -- This act however attempts to invoke Do_Something and fails
2247 -- because the lock has disappeared.
2249 elsif Ekind
(Obj_Id
) = E_Variable
2250 and then not In_Library_Level_Package_Body
(Obj_Id
)
2251 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2252 or else Has_Simple_Protected_Object
(Obj_Typ
))
2254 Processing_Actions
(Is_Protected
=> True);
2257 -- Specific cases of object renamings
2259 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2260 Obj_Id
:= Defining_Identifier
(Decl
);
2261 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2263 -- Bypass any form of processing for objects which have their
2264 -- finalization disabled. This applies only to objects at the
2267 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2270 -- Ignored Ghost object renamings do not need any cleanup
2271 -- actions because they will not appear in the final tree.
2273 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2276 -- Return object of a build-in-place function. This case is
2277 -- recognized and marked by the expansion of an extended return
2278 -- statement (see Expand_N_Extended_Return_Statement).
2280 elsif Needs_Finalization
(Obj_Typ
)
2281 and then Is_Return_Object
(Obj_Id
)
2282 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2284 Processing_Actions
(Has_No_Init
=> True);
2286 -- Detect a case where a source object has been initialized by
2287 -- a controlled function call or another object which was later
2288 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2290 -- Obj1 : CW_Type := Src_Obj;
2291 -- Obj2 : CW_Type := Function_Call (...);
2293 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2294 -- Tmp : ... := Function_Call (...)'reference;
2295 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2297 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2298 Processing_Actions
(Has_No_Init
=> True);
2301 -- Inspect the freeze node of an access-to-controlled type and
2302 -- look for a delayed finalization master. This case arises when
2303 -- the freeze actions are inserted at a later time than the
2304 -- expansion of the context. Since Build_Finalizer is never called
2305 -- on a single construct twice, the master will be ultimately
2306 -- left out and never finalized. This is also needed for freeze
2307 -- actions of designated types themselves, since in some cases the
2308 -- finalization master is associated with a designated type's
2309 -- freeze node rather than that of the access type (see handling
2310 -- for freeze actions in Build_Finalization_Master).
2312 elsif Nkind
(Decl
) = N_Freeze_Entity
2313 and then Present
(Actions
(Decl
))
2315 Typ
:= Entity
(Decl
);
2317 -- Freeze nodes for ignored Ghost types do not need cleanup
2318 -- actions because they will never appear in the final tree.
2320 if Is_Ignored_Ghost_Entity
(Typ
) then
2323 elsif (Is_Access_Type
(Typ
)
2324 and then not Is_Access_Subprogram_Type
(Typ
)
2325 and then Needs_Finalization
2326 (Available_View
(Designated_Type
(Typ
))))
2327 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2329 Old_Counter_Val
:= Counter_Val
;
2331 -- Freeze nodes are considered to be identical to packages
2332 -- and blocks in terms of nesting. The difference is that
2333 -- a finalization master created inside the freeze node is
2334 -- at the same nesting level as the node itself.
2336 Process_Declarations
(Actions
(Decl
), Preprocess
);
2338 -- The freeze node contains a finalization master
2342 and then No
(Last_Top_Level_Ctrl_Construct
)
2343 and then Counter_Val
> Old_Counter_Val
2345 Last_Top_Level_Ctrl_Construct
:= Decl
;
2349 -- Nested package declarations, avoid generics
2351 elsif Nkind
(Decl
) = N_Package_Declaration
then
2352 Pack_Id
:= Defining_Entity
(Decl
);
2353 Spec
:= Specification
(Decl
);
2355 -- Do not inspect an ignored Ghost package because all code
2356 -- found within will not appear in the final tree.
2358 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2361 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2362 Old_Counter_Val
:= Counter_Val
;
2363 Process_Declarations
2364 (Private_Declarations
(Spec
), Preprocess
);
2365 Process_Declarations
2366 (Visible_Declarations
(Spec
), Preprocess
);
2368 -- Either the visible or the private declarations contain a
2369 -- controlled object. The nested package declaration is the
2370 -- last such construct.
2374 and then No
(Last_Top_Level_Ctrl_Construct
)
2375 and then Counter_Val
> Old_Counter_Val
2377 Last_Top_Level_Ctrl_Construct
:= Decl
;
2381 -- Nested package bodies, avoid generics
2383 elsif Nkind
(Decl
) = N_Package_Body
then
2385 -- Do not inspect an ignored Ghost package body because all
2386 -- code found within will not appear in the final tree.
2388 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2391 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2394 Old_Counter_Val
:= Counter_Val
;
2395 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2397 -- The nested package body is the last construct to contain
2398 -- a controlled object.
2402 and then No
(Last_Top_Level_Ctrl_Construct
)
2403 and then Counter_Val
> Old_Counter_Val
2405 Last_Top_Level_Ctrl_Construct
:= Decl
;
2409 -- Handle a rare case caused by a controlled transient object
2410 -- created as part of a record init proc. The variable is wrapped
2411 -- in a block, but the block is not associated with a transient
2414 elsif Nkind
(Decl
) = N_Block_Statement
2415 and then Inside_Init_Proc
2417 Old_Counter_Val
:= Counter_Val
;
2419 if Present
(Handled_Statement_Sequence
(Decl
)) then
2420 Process_Declarations
2421 (Statements
(Handled_Statement_Sequence
(Decl
)),
2425 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2427 -- Either the declaration or statement list of the block has a
2428 -- controlled object.
2432 and then No
(Last_Top_Level_Ctrl_Construct
)
2433 and then Counter_Val
> Old_Counter_Val
2435 Last_Top_Level_Ctrl_Construct
:= Decl
;
2438 -- Handle the case where the original context has been wrapped in
2439 -- a block to avoid interference between exception handlers and
2440 -- At_End handlers. Treat the block as transparent and process its
2443 elsif Nkind
(Decl
) = N_Block_Statement
2444 and then Is_Finalization_Wrapper
(Decl
)
2446 if Present
(Handled_Statement_Sequence
(Decl
)) then
2447 Process_Declarations
2448 (Statements
(Handled_Statement_Sequence
(Decl
)),
2452 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2455 Prev_Non_Pragma
(Decl
);
2457 end Process_Declarations
;
2459 --------------------------------
2460 -- Process_Object_Declaration --
2461 --------------------------------
2463 procedure Process_Object_Declaration
2465 Has_No_Init
: Boolean := False;
2466 Is_Protected
: Boolean := False)
2468 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2469 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2471 Init_Typ
: Entity_Id
;
2472 -- The initialization type of the related object declaration. Note
2473 -- that this is not necessarily the same type as Obj_Typ because of
2474 -- possible type derivations.
2476 Obj_Typ
: Entity_Id
;
2477 -- The type of the related object declaration
2479 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2480 -- Func_Id denotes a build-in-place function. Generate the following
2483 -- if BIPallocfrom > Secondary_Stack'Pos
2484 -- and then BIPfinalizationmaster /= null
2487 -- type Ptr_Typ is access Obj_Typ;
2488 -- for Ptr_Typ'Storage_Pool
2489 -- use Base_Pool (BIPfinalizationmaster);
2491 -- Free (Ptr_Typ (Temp));
2495 -- Obj_Typ is the type of the current object, Temp is the original
2496 -- allocation which Obj_Id renames.
2498 procedure Find_Last_Init
2499 (Last_Init
: out Node_Id
;
2500 Body_Insert
: out Node_Id
);
2501 -- Find the last initialization call related to object declaration
2502 -- Decl. Last_Init denotes the last initialization call which follows
2503 -- Decl. Body_Insert denotes a node where the finalizer body could be
2504 -- potentially inserted after (if blocks are involved).
2506 -----------------------------
2507 -- Build_BIP_Cleanup_Stmts --
2508 -----------------------------
2510 function Build_BIP_Cleanup_Stmts
2511 (Func_Id
: Entity_Id
) return Node_Id
2513 Decls
: constant List_Id
:= New_List
;
2514 Fin_Mas_Id
: constant Entity_Id
:=
2515 Build_In_Place_Formal
2516 (Func_Id
, BIP_Finalization_Master
);
2517 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2518 Temp_Id
: constant Entity_Id
:=
2519 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2523 Free_Stmt
: Node_Id
;
2524 Pool_Id
: Entity_Id
;
2525 Ptr_Typ
: Entity_Id
;
2529 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2531 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2534 Make_Object_Renaming_Declaration
(Loc
,
2535 Defining_Identifier
=> Pool_Id
,
2537 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2539 Make_Explicit_Dereference
(Loc
,
2541 Make_Function_Call
(Loc
,
2543 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2544 Parameter_Associations
=> New_List
(
2545 Make_Explicit_Dereference
(Loc
,
2547 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2549 -- Create an access type which uses the storage pool of the
2550 -- caller's finalization master.
2553 -- type Ptr_Typ is access Func_Typ;
2555 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2558 Make_Full_Type_Declaration
(Loc
,
2559 Defining_Identifier
=> Ptr_Typ
,
2561 Make_Access_To_Object_Definition
(Loc
,
2562 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2564 -- Perform minor decoration in order to set the master and the
2565 -- storage pool attributes.
2567 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2568 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2569 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2571 -- Create an explicit free statement. Note that the free uses the
2572 -- caller's pool expressed as a renaming.
2575 Make_Free_Statement
(Loc
,
2577 Unchecked_Convert_To
(Ptr_Typ
,
2578 New_Occurrence_Of
(Temp_Id
, Loc
)));
2580 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2582 -- Create a block to house the dummy type and the instantiation as
2583 -- well as to perform the cleanup the temporary.
2589 -- Free (Ptr_Typ (Temp_Id));
2593 Make_Block_Statement
(Loc
,
2594 Declarations
=> Decls
,
2595 Handled_Statement_Sequence
=>
2596 Make_Handled_Sequence_Of_Statements
(Loc
,
2597 Statements
=> New_List
(Free_Stmt
)));
2600 -- if BIPfinalizationmaster /= null then
2604 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2605 Right_Opnd
=> Make_Null
(Loc
));
2607 -- For constrained or tagged results escalate the condition to
2608 -- include the allocation format. Generate:
2610 -- if BIPallocform > Secondary_Stack'Pos
2611 -- and then BIPfinalizationmaster /= null
2614 if not Is_Constrained
(Func_Typ
)
2615 or else Is_Tagged_Type
(Func_Typ
)
2618 Alloc
: constant Entity_Id
:=
2619 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2625 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2627 Make_Integer_Literal
(Loc
,
2629 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2631 Right_Opnd
=> Cond
);
2641 Make_If_Statement
(Loc
,
2643 Then_Statements
=> New_List
(Free_Blk
));
2644 end Build_BIP_Cleanup_Stmts
;
2646 --------------------
2647 -- Find_Last_Init --
2648 --------------------
2650 procedure Find_Last_Init
2651 (Last_Init
: out Node_Id
;
2652 Body_Insert
: out Node_Id
)
2654 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2655 -- Find the last initialization call within the statements of
2658 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2659 -- Determine whether node N denotes one of the initialization
2660 -- procedures of types Init_Typ or Obj_Typ.
2662 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2663 -- Obtain the next statement which follows list member Stmt while
2664 -- ignoring artifacts related to access-before-elaboration checks.
2666 -----------------------------
2667 -- Find_Last_Init_In_Block --
2668 -----------------------------
2670 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2671 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2675 -- Examine the individual statements of the block in reverse to
2676 -- locate the last initialization call.
2678 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2679 Stmt
:= Last
(Statements
(HSS
));
2680 while Present
(Stmt
) loop
2682 -- Peek inside nested blocks in case aborts are allowed
2684 if Nkind
(Stmt
) = N_Block_Statement
then
2685 return Find_Last_Init_In_Block
(Stmt
);
2687 elsif Is_Init_Call
(Stmt
) then
2696 end Find_Last_Init_In_Block
;
2702 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2703 function Is_Init_Proc_Of
2704 (Subp_Id
: Entity_Id
;
2705 Typ
: Entity_Id
) return Boolean;
2706 -- Determine whether subprogram Subp_Id is a valid init proc of
2709 ---------------------
2710 -- Is_Init_Proc_Of --
2711 ---------------------
2713 function Is_Init_Proc_Of
2714 (Subp_Id
: Entity_Id
;
2715 Typ
: Entity_Id
) return Boolean
2717 Deep_Init
: Entity_Id
:= Empty
;
2718 Prim_Init
: Entity_Id
:= Empty
;
2719 Type_Init
: Entity_Id
:= Empty
;
2722 -- Obtain all possible initialization routines of the
2723 -- related type and try to match the subprogram entity
2724 -- against one of them.
2728 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2730 -- Primitive Initialize
2732 if Is_Controlled
(Typ
) then
2733 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2735 if Present
(Prim_Init
) then
2736 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2740 -- Type initialization routine
2742 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2743 Type_Init
:= Base_Init_Proc
(Typ
);
2747 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2749 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2751 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2752 end Is_Init_Proc_Of
;
2756 Call_Id
: Entity_Id
;
2758 -- Start of processing for Is_Init_Call
2761 if Nkind
(N
) = N_Procedure_Call_Statement
2762 and then Nkind
(Name
(N
)) = N_Identifier
2764 Call_Id
:= Entity
(Name
(N
));
2766 -- Consider both the type of the object declaration and its
2767 -- related initialization type.
2770 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2772 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2778 -----------------------------
2779 -- Next_Suitable_Statement --
2780 -----------------------------
2782 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2786 -- Skip call markers and Program_Error raises installed by the
2789 Result
:= Next
(Stmt
);
2790 while Present
(Result
) loop
2791 if not Nkind_In
(Result
, N_Call_Marker
,
2792 N_Raise_Program_Error
)
2797 Result
:= Next
(Result
);
2801 end Next_Suitable_Statement
;
2809 Deep_Init_Found
: Boolean := False;
2810 -- A flag set when a call to [Deep_]Initialize has been found
2812 -- Start of processing for Find_Last_Init
2816 Body_Insert
:= Empty
;
2818 -- Object renamings and objects associated with controlled
2819 -- function results do not require initialization.
2825 Stmt
:= Next_Suitable_Statement
(Decl
);
2827 -- For an object with suppressed initialization, we check whether
2828 -- there is in fact no initialization expression. If there is not,
2829 -- then this is an object declaration that has been turned into a
2830 -- different object declaration that calls the build-in-place
2831 -- function in a 'Reference attribute, as in "F(...)'Reference".
2832 -- We search for that later object declaration, so that the
2833 -- Inc_Decl will be inserted after the call. Otherwise, if the
2834 -- call raises an exception, we will finalize the (uninitialized)
2835 -- object, which is wrong.
2837 if No_Initialization
(Decl
) then
2838 if No
(Expression
(Last_Init
)) then
2840 Last_Init
:= Next
(Last_Init
);
2841 exit when No
(Last_Init
);
2842 exit when Nkind
(Last_Init
) = N_Object_Declaration
2843 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2844 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2846 and then Is_Expanded_Build_In_Place_Call
2847 (Prefix
(Expression
(Last_Init
)));
2853 -- In all other cases the initialization calls follow the related
2854 -- object. The general structure of object initialization built by
2855 -- routine Default_Initialize_Object is as follows:
2857 -- [begin -- aborts allowed
2859 -- Type_Init_Proc (Obj);
2860 -- [begin] -- exceptions allowed
2861 -- Deep_Initialize (Obj);
2862 -- [exception -- exceptions allowed
2864 -- Deep_Finalize (Obj, Self => False);
2867 -- [at end -- aborts allowed
2871 -- When aborts are allowed, the initialization calls are housed
2874 elsif Nkind
(Stmt
) = N_Block_Statement
then
2875 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2876 Body_Insert
:= Stmt
;
2878 -- Otherwise the initialization calls follow the related object
2881 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2883 -- Check for an optional call to Deep_Initialize which may
2884 -- appear within a block depending on whether the object has
2885 -- controlled components.
2887 if Present
(Stmt_2
) then
2888 if Nkind
(Stmt_2
) = N_Block_Statement
then
2889 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2891 if Present
(Call
) then
2892 Deep_Init_Found
:= True;
2894 Body_Insert
:= Stmt_2
;
2897 elsif Is_Init_Call
(Stmt_2
) then
2898 Deep_Init_Found
:= True;
2899 Last_Init
:= Stmt_2
;
2900 Body_Insert
:= Last_Init
;
2904 -- If the object lacks a call to Deep_Initialize, then it must
2905 -- have a call to its related type init proc.
2907 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2909 Body_Insert
:= Last_Init
;
2917 Count_Ins
: Node_Id
;
2919 Fin_Stmts
: List_Id
:= No_List
;
2922 Label_Id
: Entity_Id
;
2925 -- Start of processing for Process_Object_Declaration
2928 -- Handle the object type and the reference to the object
2930 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2931 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2934 if Is_Access_Type
(Obj_Typ
) then
2935 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2936 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2938 elsif Is_Concurrent_Type
(Obj_Typ
)
2939 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2941 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2942 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2944 elsif Is_Private_Type
(Obj_Typ
)
2945 and then Present
(Full_View
(Obj_Typ
))
2947 Obj_Typ
:= Full_View
(Obj_Typ
);
2948 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2950 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2951 Obj_Typ
:= Base_Type
(Obj_Typ
);
2952 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2959 Set_Etype
(Obj_Ref
, Obj_Typ
);
2961 -- Handle the initialization type of the object declaration
2963 Init_Typ
:= Obj_Typ
;
2965 if Is_Private_Type
(Init_Typ
)
2966 and then Present
(Full_View
(Init_Typ
))
2968 Init_Typ
:= Full_View
(Init_Typ
);
2970 elsif Is_Untagged_Derivation
(Init_Typ
) then
2971 Init_Typ
:= Root_Type
(Init_Typ
);
2978 -- Set a new value for the state counter and insert the statement
2979 -- after the object declaration. Generate:
2981 -- Counter := <value>;
2984 Make_Assignment_Statement
(Loc
,
2985 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2986 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2988 -- Insert the counter after all initialization has been done. The
2989 -- place of insertion depends on the context.
2991 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
) then
2993 -- The object is initialized by a build-in-place function call.
2994 -- The counter insertion point is after the function call.
2996 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
2997 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3000 -- The object is initialized by an aggregate. Insert the counter
3001 -- after the last aggregate assignment.
3003 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3004 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3007 -- In all other cases the counter is inserted after the last call
3008 -- to either [Deep_]Initialize or the type-specific init proc.
3011 Find_Last_Init
(Count_Ins
, Body_Ins
);
3014 -- In all other cases the counter is inserted after the last call to
3015 -- either [Deep_]Initialize or the type-specific init proc.
3018 Find_Last_Init
(Count_Ins
, Body_Ins
);
3021 -- If the Initialize function is null or trivial, the call will have
3022 -- been replaced with a null statement, in which case place counter
3023 -- declaration after object declaration itself.
3025 if No
(Count_Ins
) then
3029 Insert_After
(Count_Ins
, Inc_Decl
);
3032 -- If the current declaration is the last in the list, the finalizer
3033 -- body needs to be inserted after the set counter statement for the
3034 -- current object declaration. This is complicated by the fact that
3035 -- the set counter statement may appear in abort deferred block. In
3036 -- that case, the proper insertion place is after the block.
3038 if No
(Finalizer_Insert_Nod
) then
3040 -- Insertion after an abort deferred block
3042 if Present
(Body_Ins
) then
3043 Finalizer_Insert_Nod
:= Body_Ins
;
3045 Finalizer_Insert_Nod
:= Inc_Decl
;
3049 -- Create the associated label with this object, generate:
3051 -- L<counter> : label;
3054 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3056 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3057 Label
:= Make_Label
(Loc
, Label_Id
);
3059 Prepend_To
(Finalizer_Decls
,
3060 Make_Implicit_Label_Declaration
(Loc
,
3061 Defining_Identifier
=> Entity
(Label_Id
),
3062 Label_Construct
=> Label
));
3064 -- Create the associated jump with this object, generate:
3066 -- when <counter> =>
3069 Prepend_To
(Jump_Alts
,
3070 Make_Case_Statement_Alternative
(Loc
,
3071 Discrete_Choices
=> New_List
(
3072 Make_Integer_Literal
(Loc
, Counter_Val
)),
3073 Statements
=> New_List
(
3074 Make_Goto_Statement
(Loc
,
3075 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3077 -- Insert the jump destination, generate:
3081 Append_To
(Finalizer_Stmts
, Label
);
3083 -- Processing for simple protected objects. Such objects require
3084 -- manual finalization of their lock managers.
3086 if Is_Protected
then
3087 if Is_Simple_Protected_Type
(Obj_Typ
) then
3088 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3090 if Present
(Fin_Call
) then
3091 Fin_Stmts
:= New_List
(Fin_Call
);
3094 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3095 if Is_Record_Type
(Obj_Typ
) then
3096 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3097 elsif Is_Array_Type
(Obj_Typ
) then
3098 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3104 -- System.Tasking.Protected_Objects.Finalize_Protection
3112 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3113 Fin_Stmts
:= New_List
(
3114 Make_Block_Statement
(Loc
,
3115 Handled_Statement_Sequence
=>
3116 Make_Handled_Sequence_Of_Statements
(Loc
,
3117 Statements
=> Fin_Stmts
,
3119 Exception_Handlers
=> New_List
(
3120 Make_Exception_Handler
(Loc
,
3121 Exception_Choices
=> New_List
(
3122 Make_Others_Choice
(Loc
)),
3124 Statements
=> New_List
(
3125 Make_Null_Statement
(Loc
)))))));
3128 -- Processing for regular controlled objects
3133 -- [Deep_]Finalize (Obj);
3136 -- when Id : others =>
3137 -- if not Raised then
3139 -- Save_Occurrence (E, Id);
3148 -- Guard against a missing [Deep_]Finalize when the object type
3149 -- was not properly frozen.
3151 if No
(Fin_Call
) then
3152 Fin_Call
:= Make_Null_Statement
(Loc
);
3155 -- For CodePeer, the exception handlers normally generated here
3156 -- generate complex flowgraphs which result in capacity problems.
3157 -- Omitting these handlers for CodePeer is justified as follows:
3159 -- If a handler is dead, then omitting it is surely ok
3161 -- If a handler is live, then CodePeer should flag the
3162 -- potentially-exception-raising construct that causes it
3163 -- to be live. That is what we are interested in, not what
3164 -- happens after the exception is raised.
3166 if Exceptions_OK
and not CodePeer_Mode
then
3167 Fin_Stmts
:= New_List
(
3168 Make_Block_Statement
(Loc
,
3169 Handled_Statement_Sequence
=>
3170 Make_Handled_Sequence_Of_Statements
(Loc
,
3171 Statements
=> New_List
(Fin_Call
),
3173 Exception_Handlers
=> New_List
(
3174 Build_Exception_Handler
3175 (Finalizer_Data
, For_Package
)))));
3177 -- When exception handlers are prohibited, the finalization call
3178 -- appears unprotected. Any exception raised during finalization
3179 -- will bypass the circuitry which ensures the cleanup of all
3180 -- remaining objects.
3183 Fin_Stmts
:= New_List
(Fin_Call
);
3186 -- If we are dealing with a return object of a build-in-place
3187 -- function, generate the following cleanup statements:
3189 -- if BIPallocfrom > Secondary_Stack'Pos
3190 -- and then BIPfinalizationmaster /= null
3193 -- type Ptr_Typ is access Obj_Typ;
3194 -- for Ptr_Typ'Storage_Pool use
3195 -- Base_Pool (BIPfinalizationmaster.all).all;
3197 -- Free (Ptr_Typ (Temp));
3201 -- The generated code effectively detaches the temporary from the
3202 -- caller finalization master and deallocates the object.
3204 if Is_Return_Object
(Obj_Id
) then
3206 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3208 if Is_Build_In_Place_Function
(Func_Id
)
3209 and then Needs_BIP_Finalization_Master
(Func_Id
)
3211 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3216 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
3217 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3219 -- Temporaries created for the purpose of "exporting" a
3220 -- transient object out of an Expression_With_Actions (EWA)
3221 -- need guards. The following illustrates the usage of such
3224 -- Access_Typ : access [all] Obj_Typ;
3225 -- Temp : Access_Typ := null;
3226 -- <Counter> := ...;
3229 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3230 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3232 -- Temp := Ctrl_Trans'Unchecked_Access;
3235 -- The finalization machinery does not process EWA nodes as
3236 -- this may lead to premature finalization of expressions. Note
3237 -- that Temp is marked as being properly initialized regardless
3238 -- of whether the initialization of Ctrl_Trans succeeded. Since
3239 -- a failed initialization may leave Temp with a value of null,
3240 -- add a guard to handle this case:
3242 -- if Obj /= null then
3243 -- <object finalization statements>
3246 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3247 N_Object_Declaration
3249 Fin_Stmts
:= New_List
(
3250 Make_If_Statement
(Loc
,
3253 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3254 Right_Opnd
=> Make_Null
(Loc
)),
3255 Then_Statements
=> Fin_Stmts
));
3257 -- Return objects use a flag to aid in processing their
3258 -- potential finalization when the enclosing function fails
3259 -- to return properly. Generate:
3262 -- <object finalization statements>
3266 Fin_Stmts
:= New_List
(
3267 Make_If_Statement
(Loc
,
3272 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3274 Then_Statements
=> Fin_Stmts
));
3279 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3281 -- Since the declarations are examined in reverse, the state counter
3282 -- must be decremented in order to keep with the true position of
3285 Counter_Val
:= Counter_Val
- 1;
3286 end Process_Object_Declaration
;
3288 -------------------------------------
3289 -- Process_Tagged_Type_Declaration --
3290 -------------------------------------
3292 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3293 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3294 DT_Ptr
: constant Entity_Id
:=
3295 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3298 -- Ada.Tags.Unregister_Tag (<Typ>P);
3300 Append_To
(Tagged_Type_Stmts
,
3301 Make_Procedure_Call_Statement
(Loc
,
3303 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3304 Parameter_Associations
=> New_List
(
3305 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3306 end Process_Tagged_Type_Declaration
;
3308 -- Start of processing for Build_Finalizer
3313 -- Do not perform this expansion in SPARK mode because it is not
3316 if GNATprove_Mode
then
3320 -- Step 1: Extract all lists which may contain controlled objects or
3321 -- library-level tagged types.
3323 if For_Package_Spec
then
3324 Decls
:= Visible_Declarations
(Specification
(N
));
3325 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3327 -- Retrieve the package spec id
3329 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3331 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3332 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3335 -- Accept statement, block, entry body, package body, protected body,
3336 -- subprogram body or task body.
3339 Decls
:= Declarations
(N
);
3340 HSS
:= Handled_Statement_Sequence
(N
);
3342 if Present
(HSS
) then
3343 if Present
(Statements
(HSS
)) then
3344 Stmts
:= Statements
(HSS
);
3347 if Present
(At_End_Proc
(HSS
)) then
3348 Prev_At_End
:= At_End_Proc
(HSS
);
3352 -- Retrieve the package spec id for package bodies
3354 if For_Package_Body
then
3355 Spec_Id
:= Corresponding_Spec
(N
);
3359 -- Do not process nested packages since those are handled by the
3360 -- enclosing scope's finalizer. Do not process non-expanded package
3361 -- instantiations since those will be re-analyzed and re-expanded.
3365 (not Is_Library_Level_Entity
(Spec_Id
)
3367 -- Nested packages are considered to be library level entities,
3368 -- but do not need to be processed separately. True library level
3369 -- packages have a scope value of 1.
3371 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3372 or else (Is_Generic_Instance
(Spec_Id
)
3373 and then Package_Instantiation
(Spec_Id
) /= N
))
3378 -- Step 2: Object [pre]processing
3382 -- Preprocess the visible declarations now in order to obtain the
3383 -- correct number of controlled object by the time the private
3384 -- declarations are processed.
3386 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3388 -- From all the possible contexts, only package specifications may
3389 -- have private declarations.
3391 if For_Package_Spec
then
3392 Process_Declarations
3393 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3396 -- The current context may lack controlled objects, but require some
3397 -- other form of completion (task termination for instance). In such
3398 -- cases, the finalizer must be created and carry the additional
3401 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3405 -- The preprocessing has determined that the context has controlled
3406 -- objects or library-level tagged types.
3408 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3410 -- Private declarations are processed first in order to preserve
3411 -- possible dependencies between public and private objects.
3413 if For_Package_Spec
then
3414 Process_Declarations
(Priv_Decls
);
3417 Process_Declarations
(Decls
);
3423 -- Preprocess both declarations and statements
3425 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3426 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3428 -- At this point it is known that N has controlled objects. Ensure
3429 -- that N has a declarative list since the finalizer spec will be
3432 if Has_Ctrl_Objs
and then No
(Decls
) then
3433 Set_Declarations
(N
, New_List
);
3434 Decls
:= Declarations
(N
);
3435 Spec_Decls
:= Decls
;
3438 -- The current context may lack controlled objects, but require some
3439 -- other form of completion (task termination for instance). In such
3440 -- cases, the finalizer must be created and carry the additional
3443 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3447 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3448 Process_Declarations
(Stmts
);
3449 Process_Declarations
(Decls
);
3453 -- Step 3: Finalizer creation
3455 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3458 end Build_Finalizer
;
3460 --------------------------
3461 -- Build_Finalizer_Call --
3462 --------------------------
3464 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3465 Is_Prot_Body
: constant Boolean :=
3466 Nkind
(N
) = N_Subprogram_Body
3467 and then Is_Protected_Subprogram_Body
(N
);
3468 -- Determine whether N denotes the protected version of a subprogram
3469 -- which belongs to a protected type.
3471 Loc
: constant Source_Ptr
:= Sloc
(N
);
3475 -- Do not perform this expansion in SPARK mode because we do not create
3476 -- finalizers in the first place.
3478 if GNATprove_Mode
then
3482 -- The At_End handler should have been assimilated by the finalizer
3484 HSS
:= Handled_Statement_Sequence
(N
);
3485 pragma Assert
(No
(At_End_Proc
(HSS
)));
3487 -- If the construct to be cleaned up is a protected subprogram body, the
3488 -- finalizer call needs to be associated with the block which wraps the
3489 -- unprotected version of the subprogram. The following illustrates this
3492 -- procedure Prot_SubpP is
3493 -- procedure finalizer is
3495 -- Service_Entries (Prot_Obj);
3502 -- Prot_SubpN (Prot_Obj);
3508 if Is_Prot_Body
then
3509 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3511 -- An At_End handler and regular exception handlers cannot coexist in
3512 -- the same statement sequence. Wrap the original statements in a block.
3514 elsif Present
(Exception_Handlers
(HSS
)) then
3516 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3521 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3523 Set_Handled_Statement_Sequence
(N
,
3524 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3526 HSS
:= Handled_Statement_Sequence
(N
);
3527 Set_End_Label
(HSS
, End_Lab
);
3531 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3533 -- Attach reference to finalizer to tree, for LLVM use
3535 Set_Parent
(At_End_Proc
(HSS
), HSS
);
3537 Analyze
(At_End_Proc
(HSS
));
3538 Expand_At_End_Handler
(HSS
, Empty
);
3539 end Build_Finalizer_Call
;
3541 ---------------------
3542 -- Build_Late_Proc --
3543 ---------------------
3545 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3547 for Final_Prim
in Name_Of
'Range loop
3548 if Name_Of
(Final_Prim
) = Nam
then
3551 (Prim
=> Final_Prim
,
3553 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3556 end Build_Late_Proc
;
3558 -------------------------------
3559 -- Build_Object_Declarations --
3560 -------------------------------
3562 procedure Build_Object_Declarations
3563 (Data
: out Finalization_Exception_Data
;
3566 For_Package
: Boolean := False)
3571 -- This variable captures an unused dummy internal entity, see the
3572 -- comment associated with its use.
3575 pragma Assert
(Decls
/= No_List
);
3577 -- Always set the proper location as it may be needed even when
3578 -- exception propagation is forbidden.
3582 if Restriction_Active
(No_Exception_Propagation
) then
3583 Data
.Abort_Id
:= Empty
;
3585 Data
.Raised_Id
:= Empty
;
3589 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3591 -- In certain scenarios, finalization can be triggered by an abort. If
3592 -- the finalization itself fails and raises an exception, the resulting
3593 -- Program_Error must be supressed and replaced by an abort signal. In
3594 -- order to detect this scenario, save the state of entry into the
3595 -- finalization code.
3597 -- This is not needed for library-level finalizers as they are called by
3598 -- the environment task and cannot be aborted.
3600 if not For_Package
then
3601 if Abort_Allowed
then
3602 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3605 -- Abort_Id : constant Boolean := <A_Expr>;
3608 Make_Object_Declaration
(Loc
,
3609 Defining_Identifier
=> Data
.Abort_Id
,
3610 Constant_Present
=> True,
3611 Object_Definition
=>
3612 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3614 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3616 -- Abort is not required
3619 -- Generate a dummy entity to ensure that the internal symbols are
3620 -- in sync when a unit is compiled with and without aborts.
3622 Dummy
:= Make_Temporary
(Loc
, 'A');
3623 Data
.Abort_Id
:= Empty
;
3626 -- Library-level finalizers
3629 Data
.Abort_Id
:= Empty
;
3632 if Exception_Extra_Info
then
3633 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3636 -- E_Id : Exception_Occurrence;
3639 Make_Object_Declaration
(Loc
,
3640 Defining_Identifier
=> Data
.E_Id
,
3641 Object_Definition
=>
3642 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3643 Set_No_Initialization
(Decl
);
3645 Append_To
(Decls
, Decl
);
3652 -- Raised_Id : Boolean := False;
3655 Make_Object_Declaration
(Loc
,
3656 Defining_Identifier
=> Data
.Raised_Id
,
3657 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3658 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3659 end Build_Object_Declarations
;
3661 ---------------------------
3662 -- Build_Raise_Statement --
3663 ---------------------------
3665 function Build_Raise_Statement
3666 (Data
: Finalization_Exception_Data
) return Node_Id
3672 -- Standard run-time use the specialized routine
3673 -- Raise_From_Controlled_Operation.
3675 if Exception_Extra_Info
3676 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3679 Make_Procedure_Call_Statement
(Data
.Loc
,
3682 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3683 Parameter_Associations
=>
3684 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3686 -- Restricted run-time: exception messages are not supported and hence
3687 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3692 Make_Raise_Program_Error
(Data
.Loc
,
3693 Reason
=> PE_Finalize_Raised_Exception
);
3698 -- Raised_Id and then not Abort_Id
3702 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3704 if Present
(Data
.Abort_Id
) then
3705 Expr
:= Make_And_Then
(Data
.Loc
,
3708 Make_Op_Not
(Data
.Loc
,
3709 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3714 -- if Raised_Id and then not Abort_Id then
3715 -- Raise_From_Controlled_Operation (E_Id);
3717 -- raise Program_Error; -- restricted runtime
3721 Make_If_Statement
(Data
.Loc
,
3723 Then_Statements
=> New_List
(Stmt
));
3724 end Build_Raise_Statement
;
3726 -----------------------------
3727 -- Build_Record_Deep_Procs --
3728 -----------------------------
3730 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3734 (Prim
=> Initialize_Case
,
3736 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3738 if not Is_Limited_View
(Typ
) then
3741 (Prim
=> Adjust_Case
,
3743 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3746 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3747 -- suppressed since these routine will not be used.
3749 if not Restriction_Active
(No_Finalization
) then
3752 (Prim
=> Finalize_Case
,
3754 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3756 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3758 if not CodePeer_Mode
then
3761 (Prim
=> Address_Case
,
3763 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3766 end Build_Record_Deep_Procs
;
3772 function Cleanup_Array
3775 Typ
: Entity_Id
) return List_Id
3777 Loc
: constant Source_Ptr
:= Sloc
(N
);
3778 Index_List
: constant List_Id
:= New_List
;
3780 function Free_Component
return List_Id
;
3781 -- Generate the code to finalize the task or protected subcomponents
3782 -- of a single component of the array.
3784 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3785 -- Generate a loop over one dimension of the array
3787 --------------------
3788 -- Free_Component --
3789 --------------------
3791 function Free_Component
return List_Id
is
3792 Stmts
: List_Id
:= New_List
;
3794 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3797 -- Component type is known to contain tasks or protected objects
3800 Make_Indexed_Component
(Loc
,
3801 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3802 Expressions
=> Index_List
);
3804 Set_Etype
(Tsk
, C_Typ
);
3806 if Is_Task_Type
(C_Typ
) then
3807 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3809 elsif Is_Simple_Protected_Type
(C_Typ
) then
3810 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3812 elsif Is_Record_Type
(C_Typ
) then
3813 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3815 elsif Is_Array_Type
(C_Typ
) then
3816 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3822 ------------------------
3823 -- Free_One_Dimension --
3824 ------------------------
3826 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3830 if Dim
> Number_Dimensions
(Typ
) then
3831 return Free_Component
;
3833 -- Here we generate the required loop
3836 Index
:= Make_Temporary
(Loc
, 'J');
3837 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3840 Make_Implicit_Loop_Statement
(N
,
3841 Identifier
=> Empty
,
3843 Make_Iteration_Scheme
(Loc
,
3844 Loop_Parameter_Specification
=>
3845 Make_Loop_Parameter_Specification
(Loc
,
3846 Defining_Identifier
=> Index
,
3847 Discrete_Subtype_Definition
=>
3848 Make_Attribute_Reference
(Loc
,
3849 Prefix
=> Duplicate_Subexpr
(Obj
),
3850 Attribute_Name
=> Name_Range
,
3851 Expressions
=> New_List
(
3852 Make_Integer_Literal
(Loc
, Dim
))))),
3853 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3855 end Free_One_Dimension
;
3857 -- Start of processing for Cleanup_Array
3860 return Free_One_Dimension
(1);
3863 --------------------
3864 -- Cleanup_Record --
3865 --------------------
3867 function Cleanup_Record
3870 Typ
: Entity_Id
) return List_Id
3872 Loc
: constant Source_Ptr
:= Sloc
(N
);
3875 Stmts
: constant List_Id
:= New_List
;
3876 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3879 if Has_Discriminants
(U_Typ
)
3880 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3881 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3884 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3886 -- For now, do not attempt to free a component that may appear in a
3887 -- variant, and instead issue a warning. Doing this "properly" would
3888 -- require building a case statement and would be quite a mess. Note
3889 -- that the RM only requires that free "work" for the case of a task
3890 -- access value, so already we go way beyond this in that we deal
3891 -- with the array case and non-discriminated record cases.
3894 ("task/protected object in variant record will not be freed??", N
);
3895 return New_List
(Make_Null_Statement
(Loc
));
3898 Comp
:= First_Component
(Typ
);
3899 while Present
(Comp
) loop
3900 if Has_Task
(Etype
(Comp
))
3901 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3904 Make_Selected_Component
(Loc
,
3905 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3906 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3907 Set_Etype
(Tsk
, Etype
(Comp
));
3909 if Is_Task_Type
(Etype
(Comp
)) then
3910 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3912 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3913 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3915 elsif Is_Record_Type
(Etype
(Comp
)) then
3917 -- Recurse, by generating the prefix of the argument to
3918 -- the eventual cleanup call.
3920 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3922 elsif Is_Array_Type
(Etype
(Comp
)) then
3923 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3927 Next_Component
(Comp
);
3933 ------------------------------
3934 -- Cleanup_Protected_Object --
3935 ------------------------------
3937 function Cleanup_Protected_Object
3939 Ref
: Node_Id
) return Node_Id
3941 Loc
: constant Source_Ptr
:= Sloc
(N
);
3944 -- For restricted run-time libraries (Ravenscar), tasks are
3945 -- non-terminating, and protected objects can only appear at library
3946 -- level, so we do not want finalization of protected objects.
3948 if Restricted_Profile
then
3953 Make_Procedure_Call_Statement
(Loc
,
3955 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3956 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3958 end Cleanup_Protected_Object
;
3964 function Cleanup_Task
3966 Ref
: Node_Id
) return Node_Id
3968 Loc
: constant Source_Ptr
:= Sloc
(N
);
3971 -- For restricted run-time libraries (Ravenscar), tasks are
3972 -- non-terminating and they can only appear at library level,
3973 -- so we do not want finalization of task objects.
3975 if Restricted_Profile
then
3980 Make_Procedure_Call_Statement
(Loc
,
3982 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3983 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3987 --------------------------------------
3988 -- Check_Unnesting_Elaboration_Code --
3989 --------------------------------------
3991 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
3992 Loc
: constant Source_Ptr
:= Sloc
(N
);
3994 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
3995 -- Check recursively whether a loop or block contains a subprogram that
3996 -- may need an activation record.
3998 function First_Local_Scope
(L
: List_Id
) return Entity_Id
;
3999 -- Find first block or loop that contains a subprogram and is not itself
4000 -- nested within another local scope.
4002 --------------------------
4003 -- Contains_Subprogram --
4004 --------------------------
4006 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4010 E
:= First_Entity
(Blk
);
4012 while Present
(E
) loop
4013 if Is_Subprogram
(E
) then
4016 elsif Ekind_In
(E
, E_Block
, E_Loop
)
4017 and then Contains_Subprogram
(E
)
4026 end Contains_Subprogram
;
4028 -----------------------
4029 -- Find_Local_Scope --
4030 -----------------------
4032 function First_Local_Scope
(L
: List_Id
) return Entity_Id
is
4038 while Present
(Stat
) loop
4039 case Nkind
(Stat
) is
4040 when N_Block_Statement
=>
4041 if Present
(Identifier
(Stat
)) then
4042 return Entity
(Identifier
(Stat
));
4045 when N_Loop_Statement
=>
4046 if Contains_Subprogram
(Entity
(Identifier
(Stat
))) then
4047 return Entity
(Identifier
(Stat
));
4050 when N_If_Statement
=>
4051 Scop
:= First_Local_Scope
(Then_Statements
(Stat
));
4053 if Present
(Scop
) then
4057 Scop
:= First_Local_Scope
(Else_Statements
(Stat
));
4059 if Present
(Scop
) then
4066 Elif
:= First
(Elsif_Parts
(Stat
));
4068 while Present
(Elif
) loop
4069 Scop
:= First_Local_Scope
(Statements
(Elif
));
4071 if Present
(Scop
) then
4079 when N_Case_Statement
=>
4083 Alt
:= First
(Alternatives
(Stat
));
4085 while Present
(Alt
) loop
4086 Scop
:= First_Local_Scope
(Statements
(Alt
));
4088 if Present
(Scop
) then
4096 when N_Subprogram_Body
=>
4097 return Defining_Entity
(Stat
);
4106 end First_Local_Scope
;
4110 Elab_Body
: Node_Id
;
4111 Elab_Call
: Node_Id
;
4112 Elab_Proc
: Entity_Id
;
4115 -- Start of processing for Check_Unnesting_Elaboration_Code
4118 if Unnest_Subprogram_Mode
4119 and then Present
(Handled_Statement_Sequence
(N
))
4120 and then Is_Compilation_Unit
(Current_Scope
)
4122 Ent
:= First_Local_Scope
4123 (Statements
(Handled_Statement_Sequence
(N
)));
4125 if Present
(Ent
) then
4127 Make_Defining_Identifier
(Loc
,
4128 Chars
=> New_Internal_Name
('I'));
4131 Make_Subprogram_Body
(Loc
,
4133 Make_Procedure_Specification
(Loc
,
4134 Defining_Unit_Name
=> Elab_Proc
),
4135 Declarations
=> New_List
,
4136 Handled_Statement_Sequence
=>
4137 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4140 Make_Procedure_Call_Statement
(Loc
,
4141 Name
=> New_Occurrence_Of
(Elab_Proc
, Loc
));
4143 Append_To
(Declarations
(N
), Elab_Body
);
4144 Analyze
(Elab_Body
);
4145 Set_Has_Nested_Subprogram
(Elab_Proc
);
4147 Set_Handled_Statement_Sequence
(N
,
4148 Make_Handled_Sequence_Of_Statements
(Loc
,
4149 Statements
=> New_List
(Elab_Call
)));
4151 Analyze
(Elab_Call
);
4153 -- The scope of all blocks and loops in the elaboration code is
4154 -- now the constructed elaboration procedure. Nested subprograms
4155 -- within those blocks will have activation records if they
4156 -- contain references to entities in the enclosing block.
4158 while Present
(Ent
) loop
4159 Set_Scope
(Ent
, Elab_Proc
);
4164 end Check_Unnesting_Elaboration_Code
;
4166 ------------------------------
4167 -- Check_Visibly_Controlled --
4168 ------------------------------
4170 procedure Check_Visibly_Controlled
4171 (Prim
: Final_Primitives
;
4173 E
: in out Entity_Id
;
4174 Cref
: in out Node_Id
)
4176 Parent_Type
: Entity_Id
;
4180 if Is_Derived_Type
(Typ
)
4181 and then Comes_From_Source
(E
)
4182 and then not Present
(Overridden_Operation
(E
))
4184 -- We know that the explicit operation on the type does not override
4185 -- the inherited operation of the parent, and that the derivation
4186 -- is from a private type that is not visibly controlled.
4188 Parent_Type
:= Etype
(Typ
);
4189 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4191 if Present
(Op
) then
4194 -- Wrap the object to be initialized into the proper
4195 -- unchecked conversion, to be compatible with the operation
4198 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4199 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4201 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4205 end Check_Visibly_Controlled
;
4211 function Convert_View
4214 Ind
: Pos
:= 1) return Node_Id
4216 Fent
: Entity_Id
:= First_Entity
(Proc
);
4221 for J
in 2 .. Ind
loop
4225 Ftyp
:= Etype
(Fent
);
4227 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
4228 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4230 Atyp
:= Etype
(Arg
);
4233 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4234 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4237 and then Present
(Atyp
)
4238 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
4239 and then Base_Type
(Underlying_Type
(Atyp
)) =
4240 Base_Type
(Underlying_Type
(Ftyp
))
4242 return Unchecked_Convert_To
(Ftyp
, Arg
);
4244 -- If the argument is already a conversion, as generated by
4245 -- Make_Init_Call, set the target type to the type of the formal
4246 -- directly, to avoid spurious typing problems.
4248 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
4249 and then not Is_Class_Wide_Type
(Atyp
)
4251 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4252 Set_Etype
(Arg
, Ftyp
);
4255 -- Otherwise, introduce a conversion when the designated object
4256 -- has a type derived from the formal of the controlled routine.
4258 elsif Is_Private_Type
(Ftyp
)
4259 and then Present
(Atyp
)
4260 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4262 return Unchecked_Convert_To
(Ftyp
, Arg
);
4269 -------------------------------
4270 -- CW_Or_Has_Controlled_Part --
4271 -------------------------------
4273 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
4275 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
4276 end CW_Or_Has_Controlled_Part
;
4278 ------------------------
4279 -- Enclosing_Function --
4280 ------------------------
4282 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
4283 Func_Id
: Entity_Id
;
4287 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
4288 if Ekind
(Func_Id
) = E_Function
then
4292 Func_Id
:= Scope
(Func_Id
);
4296 end Enclosing_Function
;
4298 -------------------------------
4299 -- Establish_Transient_Scope --
4300 -------------------------------
4302 -- This procedure is called each time a transient block has to be inserted
4303 -- that is to say for each call to a function with unconstrained or tagged
4304 -- result. It creates a new scope on the scope stack in order to enclose
4305 -- all transient variables generated.
4307 procedure Establish_Transient_Scope
4309 Manage_Sec_Stack
: Boolean)
4311 procedure Create_Transient_Scope
(Constr
: Node_Id
);
4312 -- Place a new scope on the scope stack in order to service construct
4313 -- Constr. The new scope may also manage the secondary stack.
4315 procedure Delegate_Sec_Stack_Management
;
4316 -- Move the management of the secondary stack to the nearest enclosing
4319 function Find_Enclosing_Transient_Scope
return Entity_Id
;
4320 -- Examine the scope stack looking for the nearest enclosing transient
4321 -- scope. Return Empty if no such scope exists.
4323 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4324 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4326 ----------------------------
4327 -- Create_Transient_Scope --
4328 ----------------------------
4330 procedure Create_Transient_Scope
(Constr
: Node_Id
) is
4331 Loc
: constant Source_Ptr
:= Sloc
(N
);
4333 Iter_Loop
: Entity_Id
;
4334 Trans_Scop
: Entity_Id
;
4337 Trans_Scop
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4338 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4340 Push_Scope
(Trans_Scop
);
4341 Set_Node_To_Be_Wrapped
(Constr
);
4342 Set_Scope_Is_Transient
;
4344 -- The transient scope must also manage the secondary stack
4346 if Manage_Sec_Stack
then
4347 Set_Uses_Sec_Stack
(Trans_Scop
);
4348 Check_Restriction
(No_Secondary_Stack
, N
);
4350 -- The expansion of iterator loops generates references to objects
4351 -- in order to extract elements from a container:
4353 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4354 -- Obj : <object type> renames Ref.all.Element.all;
4356 -- These references are controlled and returned on the secondary
4357 -- stack. A new reference is created at each iteration of the loop
4358 -- and as a result it must be finalized and the space occupied by
4359 -- it on the secondary stack reclaimed at the end of the current
4362 -- When the context that requires a transient scope is a call to
4363 -- routine Reference, the node to be wrapped is the source object:
4365 -- for Obj of Container loop
4367 -- Routine Wrap_Transient_Declaration however does not generate
4368 -- a physical block as wrapping a declaration will kill it too
4369 -- early. To handle this peculiar case, mark the related iterator
4370 -- loop as requiring the secondary stack. This signals the
4371 -- finalization machinery to manage the secondary stack (see
4372 -- routine Process_Statements_For_Controlled_Objects).
4374 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4376 if Present
(Iter_Loop
) then
4377 Set_Uses_Sec_Stack
(Iter_Loop
);
4381 if Debug_Flag_W
then
4382 Write_Str
(" <Transient>");
4385 end Create_Transient_Scope
;
4387 -----------------------------------
4388 -- Delegate_Sec_Stack_Management --
4389 -----------------------------------
4391 procedure Delegate_Sec_Stack_Management
is
4392 Scop_Id
: Entity_Id
;
4393 Scop_Rec
: Scope_Stack_Entry
;
4396 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4397 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4398 Scop_Id
:= Scop_Rec
.Entity
;
4400 -- Prevent the search from going too far or within the scope space
4403 if Scop_Id
= Standard_Standard
then
4406 -- No transient scope should be encountered during the traversal
4407 -- because Establish_Transient_Scope should have already handled
4410 elsif Scop_Rec
.Is_Transient
then
4411 pragma Assert
(False);
4414 -- The construct which requires secondary stack management is
4415 -- always enclosed by a package or subprogram scope.
4417 elsif Is_Package_Or_Subprogram
(Scop_Id
) then
4418 Set_Uses_Sec_Stack
(Scop_Id
);
4419 Check_Restriction
(No_Secondary_Stack
, N
);
4425 -- At this point no suitable scope was found. This should never occur
4426 -- because a construct is always enclosed by a compilation unit which
4429 pragma Assert
(False);
4430 end Delegate_Sec_Stack_Management
;
4432 ------------------------------------
4433 -- Find_Enclosing_Transient_Scope --
4434 ------------------------------------
4436 function Find_Enclosing_Transient_Scope
return Entity_Id
is
4437 Scop_Id
: Entity_Id
;
4438 Scop_Rec
: Scope_Stack_Entry
;
4441 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4442 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4443 Scop_Id
:= Scop_Rec
.Entity
;
4445 -- Prevent the search from going too far or within the scope space
4448 if Scop_Id
= Standard_Standard
4449 or else Is_Package_Or_Subprogram
(Scop_Id
)
4453 elsif Scop_Rec
.Is_Transient
then
4459 end Find_Enclosing_Transient_Scope
;
4461 ------------------------------
4462 -- Is_Package_Or_Subprogram --
4463 ------------------------------
4465 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4467 return Ekind_In
(Id
, E_Entry
,
4473 end Is_Package_Or_Subprogram
;
4477 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
4480 -- Start of processing for Establish_Transient_Scope
4483 -- Do not create a new transient scope if there is an existing transient
4484 -- scope on the stack.
4486 if Present
(Trans_Id
) then
4488 -- If the transient scope was requested for purposes of managing the
4489 -- secondary stack, then the existing scope must perform this task.
4491 if Manage_Sec_Stack
then
4492 Set_Uses_Sec_Stack
(Trans_Id
);
4498 -- At this point it is known that the scope stack is free of transient
4499 -- scopes. Locate the proper construct which must be serviced by a new
4502 Context
:= Find_Transient_Context
(N
);
4504 if Present
(Context
) then
4505 if Nkind
(Context
) = N_Assignment_Statement
then
4507 -- An assignment statement with suppressed controlled semantics
4508 -- does not need a transient scope because finalization is not
4509 -- desirable at this point. Note that No_Ctrl_Actions is also
4510 -- set for non-controlled assignments to suppress dispatching
4513 if No_Ctrl_Actions
(Context
)
4514 and then Needs_Finalization
(Etype
(Name
(Context
)))
4516 -- When a controlled component is initialized by a function
4517 -- call, the result on the secondary stack is always assigned
4518 -- to the component. Signal the nearest suitable scope that it
4519 -- is safe to manage the secondary stack.
4521 if Manage_Sec_Stack
and then Within_Init_Proc
then
4522 Delegate_Sec_Stack_Management
;
4525 -- Otherwise the assignment is a normal transient context and thus
4526 -- requires a transient scope.
4529 Create_Transient_Scope
(Context
);
4535 Create_Transient_Scope
(Context
);
4538 end Establish_Transient_Scope
;
4540 ----------------------------
4541 -- Expand_Cleanup_Actions --
4542 ----------------------------
4544 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4545 pragma Assert
(Nkind_In
(N
, N_Block_Statement
,
4547 N_Extended_Return_Statement
,
4551 Scop
: constant Entity_Id
:= Current_Scope
;
4553 Is_Asynchronous_Call
: constant Boolean :=
4554 Nkind
(N
) = N_Block_Statement
4555 and then Is_Asynchronous_Call_Block
(N
);
4556 Is_Master
: constant Boolean :=
4557 Nkind
(N
) /= N_Extended_Return_Statement
4558 and then Nkind
(N
) /= N_Entry_Body
4559 and then Is_Task_Master
(N
);
4560 Is_Protected_Subp_Body
: constant Boolean :=
4561 Nkind
(N
) = N_Subprogram_Body
4562 and then Is_Protected_Subprogram_Body
(N
);
4563 Is_Task_Allocation
: constant Boolean :=
4564 Nkind
(N
) = N_Block_Statement
4565 and then Is_Task_Allocation_Block
(N
);
4566 Is_Task_Body
: constant Boolean :=
4567 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4569 -- We mark the secondary stack if it is used in this construct, and
4570 -- we're not returning a function result on the secondary stack, except
4571 -- that a build-in-place function that might or might not return on the
4572 -- secondary stack always needs a mark. A run-time test is required in
4573 -- the case where the build-in-place function has a BIP_Alloc extra
4574 -- parameter (see Create_Finalizer).
4576 Needs_Sec_Stack_Mark
: constant Boolean :=
4577 (Uses_Sec_Stack
(Scop
)
4579 not Sec_Stack_Needed_For_Return
(Scop
))
4581 (Is_Build_In_Place_Function
(Scop
)
4582 and then Needs_BIP_Alloc_Form
(Scop
));
4584 Needs_Custom_Cleanup
: constant Boolean :=
4585 Nkind
(N
) = N_Block_Statement
4586 and then Present
(Cleanup_Actions
(N
));
4588 Actions_Required
: constant Boolean :=
4589 Requires_Cleanup_Actions
(N
, True)
4590 or else Is_Asynchronous_Call
4592 or else Is_Protected_Subp_Body
4593 or else Is_Task_Allocation
4594 or else Is_Task_Body
4595 or else Needs_Sec_Stack_Mark
4596 or else Needs_Custom_Cleanup
;
4598 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
4602 procedure Wrap_HSS_In_Block
;
4603 -- Move HSS inside a new block along with the original exception
4604 -- handlers. Make the newly generated block the sole statement of HSS.
4606 -----------------------
4607 -- Wrap_HSS_In_Block --
4608 -----------------------
4610 procedure Wrap_HSS_In_Block
is
4612 Block_Id
: Entity_Id
;
4616 -- Preserve end label to provide proper cross-reference information
4618 End_Lab
:= End_Label
(HSS
);
4620 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
4622 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4623 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
4624 Set_Etype
(Block_Id
, Standard_Void_Type
);
4625 Set_Block_Node
(Block_Id
, Identifier
(Block
));
4627 -- Signal the finalization machinery that this particular block
4628 -- contains the original context.
4630 Set_Is_Finalization_Wrapper
(Block
);
4632 Set_Handled_Statement_Sequence
(N
,
4633 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
4634 HSS
:= Handled_Statement_Sequence
(N
);
4636 Set_First_Real_Statement
(HSS
, Block
);
4637 Set_End_Label
(HSS
, End_Lab
);
4639 -- Comment needed here, see RH for 1.306 ???
4641 if Nkind
(N
) = N_Subprogram_Body
then
4642 Set_Has_Nested_Block_With_Handler
(Scop
);
4644 end Wrap_HSS_In_Block
;
4646 -- Start of processing for Expand_Cleanup_Actions
4649 -- The current construct does not need any form of servicing
4651 if not Actions_Required
then
4654 -- If the current node is a rewritten task body and the descriptors have
4655 -- not been delayed (due to some nested instantiations), do not generate
4656 -- redundant cleanup actions.
4659 and then Nkind
(N
) = N_Subprogram_Body
4660 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4665 -- If an extended return statement contains something like
4669 -- where F is a build-in-place function call returning a controlled
4670 -- type, then a temporary object will be implicitly declared as part
4671 -- of the statement list, and this will need cleanup. In such cases,
4674 -- return Result : T := ... do
4675 -- <statements> -- possibly with handlers
4680 -- return Result : T := ... do
4681 -- declare -- no declarations
4683 -- <statements> -- possibly with handlers
4684 -- end; -- no handlers
4687 -- So Expand_Cleanup_Actions will end up being called recursively on the
4690 if Nkind
(N
) = N_Extended_Return_Statement
then
4692 Block
: constant Node_Id
:=
4693 Make_Block_Statement
(Sloc
(N
),
4694 Declarations
=> Empty_List
,
4695 Handled_Statement_Sequence
=>
4696 Handled_Statement_Sequence
(N
));
4698 Set_Handled_Statement_Sequence
(N
,
4699 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
4700 Statements
=> New_List
(Block
)));
4705 -- Analysis of the block did all the work
4710 if Needs_Custom_Cleanup
then
4711 Cln
:= Cleanup_Actions
(N
);
4717 Decls
: List_Id
:= Declarations
(N
);
4719 Mark
: Entity_Id
:= Empty
;
4720 New_Decls
: List_Id
;
4724 -- If we are generating expanded code for debugging purposes, use the
4725 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4726 -- be updated subsequently to reference the proper line in .dg files.
4727 -- If we are not debugging generated code, use No_Location instead,
4728 -- so that no debug information is generated for the cleanup code.
4729 -- This makes the behavior of the NEXT command in GDB monotonic, and
4730 -- makes the placement of breakpoints more accurate.
4732 if Debug_Generated_Code
then
4738 -- Set polling off. The finalization and cleanup code is executed
4739 -- with aborts deferred.
4741 Old_Poll
:= Polling_Required
;
4742 Polling_Required
:= False;
4744 -- A task activation call has already been built for a task
4745 -- allocation block.
4747 if not Is_Task_Allocation
then
4748 Build_Task_Activation_Call
(N
);
4752 Establish_Task_Master
(N
);
4755 New_Decls
:= New_List
;
4757 -- If secondary stack is in use, generate:
4759 -- Mnn : constant Mark_Id := SS_Mark;
4761 if Needs_Sec_Stack_Mark
then
4762 Mark
:= Make_Temporary
(Loc
, 'M');
4764 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4765 Set_Uses_Sec_Stack
(Scop
, False);
4768 -- If exception handlers are present, wrap the sequence of statements
4769 -- in a block since it is not possible to have exception handlers and
4770 -- an At_End handler in the same construct.
4772 if Present
(Exception_Handlers
(HSS
)) then
4775 -- Ensure that the First_Real_Statement field is set
4777 elsif No
(First_Real_Statement
(HSS
)) then
4778 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4781 -- Do not move the Activation_Chain declaration in the context of
4782 -- task allocation blocks. Task allocation blocks use _chain in their
4783 -- cleanup handlers and gigi complains if it is declared in the
4784 -- sequence of statements of the scope that declares the handler.
4786 if Is_Task_Allocation
then
4788 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4792 Decl
:= First
(Decls
);
4793 while Nkind
(Decl
) /= N_Object_Declaration
4794 or else Defining_Identifier
(Decl
) /= Chain
4798 -- A task allocation block should always include a _chain
4801 pragma Assert
(Present
(Decl
));
4805 Prepend_To
(New_Decls
, Decl
);
4809 -- Ensure the presence of a declaration list in order to successfully
4810 -- append all original statements to it.
4813 Set_Declarations
(N
, New_List
);
4814 Decls
:= Declarations
(N
);
4817 -- Move the declarations into the sequence of statements in order to
4818 -- have them protected by the At_End handler. It may seem weird to
4819 -- put declarations in the sequence of statement but in fact nothing
4820 -- forbids that at the tree level.
4822 Append_List_To
(Decls
, Statements
(HSS
));
4823 Set_Statements
(HSS
, Decls
);
4825 -- Reset the Sloc of the handled statement sequence to properly
4826 -- reflect the new initial "statement" in the sequence.
4828 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4830 -- The declarations of finalizer spec and auxiliary variables replace
4831 -- the old declarations that have been moved inward.
4833 Set_Declarations
(N
, New_Decls
);
4834 Analyze_Declarations
(New_Decls
);
4836 -- Generate finalization calls for all controlled objects appearing
4837 -- in the statements of N. Add context specific cleanup for various
4842 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4844 Top_Decls
=> New_Decls
,
4845 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4849 if Present
(Fin_Id
) then
4850 Build_Finalizer_Call
(N
, Fin_Id
);
4853 -- Restore saved polling mode
4855 Polling_Required
:= Old_Poll
;
4857 end Expand_Cleanup_Actions
;
4859 ---------------------------
4860 -- Expand_N_Package_Body --
4861 ---------------------------
4863 -- Add call to Activate_Tasks if body is an activator (actual processing
4864 -- is in chapter 9).
4866 -- Generate subprogram descriptor for elaboration routine
4868 -- Encode entity names in package body
4870 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4871 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
4875 -- This is done only for non-generic packages
4877 if Ekind
(Spec_Id
) = E_Package
then
4878 Push_Scope
(Spec_Id
);
4880 -- Build dispatch tables of library level tagged types
4882 if Tagged_Type_Expansion
4883 and then Is_Library_Level_Entity
(Spec_Id
)
4885 Build_Static_Dispatch_Tables
(N
);
4888 Build_Task_Activation_Call
(N
);
4890 -- Verify the run-time semantics of pragma Initial_Condition at the
4891 -- end of the body statements.
4893 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
4894 Check_Unnesting_Elaboration_Code
(N
);
4899 Set_Elaboration_Flag
(N
, Spec_Id
);
4900 Set_In_Package_Body
(Spec_Id
, False);
4902 -- Set to encode entity names in package body before gigi is called
4904 Qualify_Entity_Names
(N
);
4906 if Ekind
(Spec_Id
) /= E_Generic_Package
then
4909 Clean_Stmts
=> No_List
,
4911 Top_Decls
=> No_List
,
4912 Defer_Abort
=> False,
4915 if Present
(Fin_Id
) then
4917 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4920 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4921 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4924 Set_Finalizer
(Body_Ent
, Fin_Id
);
4928 end Expand_N_Package_Body
;
4930 ----------------------------------
4931 -- Expand_N_Package_Declaration --
4932 ----------------------------------
4934 -- Add call to Activate_Tasks if there are tasks declared and the package
4935 -- has no body. Note that in Ada 83 this may result in premature activation
4936 -- of some tasks, given that we cannot tell whether a body will eventually
4939 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4940 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4941 Spec
: constant Node_Id
:= Specification
(N
);
4945 No_Body
: Boolean := False;
4946 -- True in the case of a package declaration that is a compilation
4947 -- unit and for which no associated body will be compiled in this
4951 -- Case of a package declaration other than a compilation unit
4953 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4956 -- Case of a compilation unit that does not require a body
4958 elsif not Body_Required
(Parent
(N
))
4959 and then not Unit_Requires_Body
(Id
)
4963 -- Special case of generating calling stubs for a remote call interface
4964 -- package: even though the package declaration requires one, the body
4965 -- won't be processed in this compilation (so any stubs for RACWs
4966 -- declared in the package must be generated here, along with the spec).
4968 elsif Parent
(N
) = Cunit
(Main_Unit
)
4969 and then Is_Remote_Call_Interface
(Id
)
4970 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4975 -- For a nested instance, delay processing until freeze point
4977 if Has_Delayed_Freeze
(Id
)
4978 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4983 -- For a package declaration that implies no associated body, generate
4984 -- task activation call and RACW supporting bodies now (since we won't
4985 -- have a specific separate compilation unit for that).
4990 -- Generate RACW subprogram bodies
4992 if Has_RACW
(Id
) then
4993 Decls
:= Private_Declarations
(Spec
);
4996 Decls
:= Visible_Declarations
(Spec
);
5001 Set_Visible_Declarations
(Spec
, Decls
);
5004 Append_RACW_Bodies
(Decls
, Id
);
5005 Analyze_List
(Decls
);
5008 -- Generate task activation call as last step of elaboration
5010 if Present
(Activation_Chain_Entity
(N
)) then
5011 Build_Task_Activation_Call
(N
);
5014 -- Verify the run-time semantics of pragma Initial_Condition at the
5015 -- end of the private declarations when the package lacks a body.
5017 Expand_Pragma_Initial_Condition
(Id
, N
);
5022 -- Build dispatch tables of library level tagged types
5024 if Tagged_Type_Expansion
5025 and then (Is_Compilation_Unit
(Id
)
5026 or else (Is_Generic_Instance
(Id
)
5027 and then Is_Library_Level_Entity
(Id
)))
5029 Build_Static_Dispatch_Tables
(N
);
5032 -- Note: it is not necessary to worry about generating a subprogram
5033 -- descriptor, since the only way to get exception handlers into a
5034 -- package spec is to include instantiations, and that would cause
5035 -- generation of subprogram descriptors to be delayed in any case.
5037 -- Set to encode entity names in package spec before gigi is called
5039 Qualify_Entity_Names
(N
);
5041 if Ekind
(Id
) /= E_Generic_Package
then
5044 Clean_Stmts
=> No_List
,
5046 Top_Decls
=> No_List
,
5047 Defer_Abort
=> False,
5050 Set_Finalizer
(Id
, Fin_Id
);
5052 end Expand_N_Package_Declaration
;
5054 ----------------------------
5055 -- Find_Transient_Context --
5056 ----------------------------
5058 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
5065 while Present
(Curr
) loop
5066 case Nkind
(Curr
) is
5070 -- Declarations act as a boundary for a transient scope even if
5071 -- they are not wrapped, see Wrap_Transient_Declaration.
5073 when N_Object_Declaration
5074 | N_Object_Renaming_Declaration
5075 | N_Subtype_Declaration
5081 -- Statements and statement-like constructs act as a boundary for
5082 -- a transient scope.
5084 when N_Accept_Alternative
5085 | N_Attribute_Definition_Clause
5087 | N_Case_Statement_Alternative
5089 | N_Delay_Alternative
5090 | N_Delay_Until_Statement
5091 | N_Delay_Relative_Statement
5092 | N_Discriminant_Association
5094 | N_Entry_Body_Formal_Part
5097 | N_Iteration_Scheme
5098 | N_Terminate_Alternative
5100 pragma Assert
(Present
(Prev
));
5103 when N_Assignment_Statement
=>
5106 when N_Entry_Call_Statement
5107 | N_Procedure_Call_Statement
5109 -- When an entry or procedure call acts as the alternative of a
5110 -- conditional or timed entry call, the proper context is that
5111 -- of the alternative.
5113 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
5114 and then Nkind_In
(Parent
(Parent
(Curr
)),
5115 N_Conditional_Entry_Call
,
5118 return Parent
(Parent
(Curr
));
5120 -- General case for entry or procedure calls
5128 -- Pragma Check is not a valid transient context in GNATprove
5129 -- mode because the pragma must remain unchanged.
5132 and then Get_Pragma_Id
(Curr
) = Pragma_Check
5136 -- General case for pragmas
5142 when N_Raise_Statement
=>
5145 when N_Simple_Return_Statement
=>
5147 -- A return statement is not a valid transient context when the
5148 -- function itself requires transient scope management because
5149 -- the result will be reclaimed too early.
5151 if Requires_Transient_Scope
(Etype
5152 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
5156 -- General case for return statements
5164 when N_Attribute_Reference
=>
5165 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
5169 -- An Ada 2012 iterator specification is not a valid context
5170 -- because Analyze_Iterator_Specification already employs special
5171 -- processing for it.
5173 when N_Iterator_Specification
=>
5176 when N_Loop_Parameter_Specification
=>
5178 -- An iteration scheme is not a valid context because routine
5179 -- Analyze_Iteration_Scheme already employs special processing.
5181 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
5184 return Parent
(Curr
);
5189 -- The following nodes represent "dummy contexts" which do not
5190 -- need to be wrapped.
5192 when N_Component_Declaration
5193 | N_Discriminant_Specification
5194 | N_Parameter_Specification
5198 -- If the traversal leaves a scope without having been able to
5199 -- find a construct to wrap, something is going wrong, but this
5200 -- can happen in error situations that are not detected yet (such
5201 -- as a dynamic string in a pragma Export).
5203 when N_Block_Statement
5206 | N_Package_Declaration
5220 Curr
:= Parent
(Curr
);
5224 end Find_Transient_Context
;
5226 ----------------------------------
5227 -- Has_New_Controlled_Component --
5228 ----------------------------------
5230 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
5234 if not Is_Tagged_Type
(E
) then
5235 return Has_Controlled_Component
(E
);
5236 elsif not Is_Derived_Type
(E
) then
5237 return Has_Controlled_Component
(E
);
5240 Comp
:= First_Component
(E
);
5241 while Present
(Comp
) loop
5242 if Chars
(Comp
) = Name_uParent
then
5245 elsif Scope
(Original_Record_Component
(Comp
)) = E
5246 and then Needs_Finalization
(Etype
(Comp
))
5251 Next_Component
(Comp
);
5255 end Has_New_Controlled_Component
;
5257 ---------------------------------
5258 -- Has_Simple_Protected_Object --
5259 ---------------------------------
5261 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5263 if Has_Task
(T
) then
5266 elsif Is_Simple_Protected_Type
(T
) then
5269 elsif Is_Array_Type
(T
) then
5270 return Has_Simple_Protected_Object
(Component_Type
(T
));
5272 elsif Is_Record_Type
(T
) then
5277 Comp
:= First_Component
(T
);
5278 while Present
(Comp
) loop
5279 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5283 Next_Component
(Comp
);
5292 end Has_Simple_Protected_Object
;
5294 ------------------------------------
5295 -- Insert_Actions_In_Scope_Around --
5296 ------------------------------------
5298 procedure Insert_Actions_In_Scope_Around
5301 Manage_SS
: Boolean)
5303 Act_Before
: constant List_Id
:=
5304 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5305 Act_After
: constant List_Id
:=
5306 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5307 Act_Cleanup
: constant List_Id
:=
5308 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5309 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5310 -- Last), but this was incorrect as Process_Transients_In_Scope may
5311 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5313 procedure Process_Transients_In_Scope
5314 (First_Object
: Node_Id
;
5315 Last_Object
: Node_Id
;
5316 Related_Node
: Node_Id
);
5317 -- Find all transient objects in the list First_Object .. Last_Object
5318 -- and generate finalization actions for them. Related_Node denotes the
5319 -- node which created all transient objects.
5321 ---------------------------------
5322 -- Process_Transients_In_Scope --
5323 ---------------------------------
5325 procedure Process_Transients_In_Scope
5326 (First_Object
: Node_Id
;
5327 Last_Object
: Node_Id
;
5328 Related_Node
: Node_Id
)
5330 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
5332 Must_Hook
: Boolean := False;
5333 -- Flag denoting whether the context requires transient object
5334 -- export to the outer finalizer.
5336 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5337 -- Determine whether an arbitrary node denotes a subprogram call
5339 procedure Detect_Subprogram_Call
is
5340 new Traverse_Proc
(Is_Subprogram_Call
);
5342 procedure Process_Transient_In_Scope
5343 (Obj_Decl
: Node_Id
;
5344 Blk_Data
: Finalization_Exception_Data
;
5345 Blk_Stmts
: List_Id
);
5346 -- Generate finalization actions for a single transient object
5347 -- denoted by object declaration Obj_Decl. Blk_Data is the
5348 -- exception data of the enclosing block. Blk_Stmts denotes the
5349 -- statements of the enclosing block.
5351 ------------------------
5352 -- Is_Subprogram_Call --
5353 ------------------------
5355 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5357 -- A regular procedure or function call
5359 if Nkind
(N
) in N_Subprogram_Call
then
5365 -- Heavy expansion may relocate function calls outside the related
5366 -- node. Inspect the original node to detect the initial placement
5369 elsif Is_Rewrite_Substitution
(N
) then
5370 Detect_Subprogram_Call
(Original_Node
(N
));
5378 -- Generalized indexing always involves a function call
5380 elsif Nkind
(N
) = N_Indexed_Component
5381 and then Present
(Generalized_Indexing
(N
))
5391 end Is_Subprogram_Call
;
5393 --------------------------------
5394 -- Process_Transient_In_Scope --
5395 --------------------------------
5397 procedure Process_Transient_In_Scope
5398 (Obj_Decl
: Node_Id
;
5399 Blk_Data
: Finalization_Exception_Data
;
5400 Blk_Stmts
: List_Id
)
5402 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5403 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5405 Fin_Stmts
: List_Id
;
5406 Hook_Assign
: Node_Id
;
5407 Hook_Clear
: Node_Id
;
5408 Hook_Decl
: Node_Id
;
5409 Hook_Insert
: Node_Id
;
5413 -- Mark the transient object as successfully processed to avoid
5414 -- double finalization.
5416 Set_Is_Finalized_Transient
(Obj_Id
);
5418 -- Construct all the pieces necessary to hook and finalize the
5419 -- transient object.
5421 Build_Transient_Object_Statements
5422 (Obj_Decl
=> Obj_Decl
,
5423 Fin_Call
=> Fin_Call
,
5424 Hook_Assign
=> Hook_Assign
,
5425 Hook_Clear
=> Hook_Clear
,
5426 Hook_Decl
=> Hook_Decl
,
5427 Ptr_Decl
=> Ptr_Decl
);
5429 -- The context contains at least one subprogram call which may
5430 -- raise an exception. This scenario employs "hooking" to pass
5431 -- transient objects to the enclosing finalizer in case of an
5436 -- Add the access type which provides a reference to the
5437 -- transient object. Generate:
5439 -- type Ptr_Typ is access all Desig_Typ;
5441 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5443 -- Add the temporary which acts as a hook to the transient
5444 -- object. Generate:
5446 -- Hook : Ptr_Typ := null;
5448 Insert_Action
(Obj_Decl
, Hook_Decl
);
5450 -- When the transient object is initialized by an aggregate,
5451 -- the hook must capture the object after the last aggregate
5452 -- assignment takes place. Only then is the object considered
5453 -- fully initialized. Generate:
5455 -- Hook := Ptr_Typ (Obj_Id);
5457 -- Hook := Obj_Id'Unrestricted_Access;
5459 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
5460 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
5462 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5464 -- Otherwise the hook seizes the related object immediately
5467 Hook_Insert
:= Obj_Decl
;
5470 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5473 -- When exception propagation is enabled wrap the hook clear
5474 -- statement and the finalization call into a block to catch
5475 -- potential exceptions raised during finalization. Generate:
5479 -- [Deep_]Finalize (Obj_Ref);
5483 -- if not Raised then
5486 -- (Enn, Get_Current_Excep.all.all);
5490 if Exceptions_OK
then
5491 Fin_Stmts
:= New_List
;
5494 Append_To
(Fin_Stmts
, Hook_Clear
);
5497 Append_To
(Fin_Stmts
, Fin_Call
);
5499 Prepend_To
(Blk_Stmts
,
5500 Make_Block_Statement
(Loc
,
5501 Handled_Statement_Sequence
=>
5502 Make_Handled_Sequence_Of_Statements
(Loc
,
5503 Statements
=> Fin_Stmts
,
5504 Exception_Handlers
=> New_List
(
5505 Build_Exception_Handler
(Blk_Data
)))));
5507 -- Otherwise generate:
5510 -- [Deep_]Finalize (Obj_Ref);
5512 -- Note that the statements are inserted in reverse order to
5513 -- achieve the desired final order outlined above.
5516 Prepend_To
(Blk_Stmts
, Fin_Call
);
5519 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5522 end Process_Transient_In_Scope
;
5526 Built
: Boolean := False;
5527 Blk_Data
: Finalization_Exception_Data
;
5528 Blk_Decl
: Node_Id
:= Empty
;
5529 Blk_Decls
: List_Id
:= No_List
;
5531 Blk_Stmts
: List_Id
;
5535 -- Start of processing for Process_Transients_In_Scope
5538 -- The expansion performed by this routine is as follows:
5540 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5541 -- Hook_1 : Ptr_Typ_1 := null;
5542 -- Ctrl_Trans_Obj_1 : ...;
5543 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5545 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5546 -- Hook_N : Ptr_Typ_N := null;
5547 -- Ctrl_Trans_Obj_N : ...;
5548 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5551 -- Abrt : constant Boolean := ...;
5552 -- Ex : Exception_Occurrence;
5553 -- Raised : Boolean := False;
5560 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5564 -- if not Raised then
5566 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5571 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5575 -- if not Raised then
5577 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5582 -- if Raised and not Abrt then
5583 -- Raise_From_Controlled_Operation (Ex);
5587 -- Recognize a scenario where the transient context is an object
5588 -- declaration initialized by a build-in-place function call:
5590 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5592 -- The rough expansion of the above is:
5594 -- Temp : ... := Ctrl_Func_Call;
5596 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5598 -- The finalization of any transient object must happen after the
5599 -- build-in-place function call is executed.
5601 if Nkind
(N
) = N_Object_Declaration
5602 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5605 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5607 -- Search the context for at least one subprogram call. If found, the
5608 -- machinery exports all transient objects to the enclosing finalizer
5609 -- due to the possibility of abnormal call termination.
5612 Detect_Subprogram_Call
(N
);
5613 Blk_Ins
:= Last_Object
;
5617 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5620 -- Examine all objects in the list First_Object .. Last_Object
5622 Obj_Decl
:= First_Object
;
5623 while Present
(Obj_Decl
) loop
5624 if Nkind
(Obj_Decl
) = N_Object_Declaration
5625 and then Analyzed
(Obj_Decl
)
5626 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5628 -- Do not process the node to be wrapped since it will be
5629 -- handled by the enclosing finalizer.
5631 and then Obj_Decl
/= Related_Node
5633 Loc
:= Sloc
(Obj_Decl
);
5635 -- Before generating the cleanup code for the first transient
5636 -- object, create a wrapper block which houses all hook clear
5637 -- statements and finalization calls. This wrapper is needed by
5642 Blk_Stmts
:= New_List
;
5645 -- Abrt : constant Boolean := ...;
5646 -- Ex : Exception_Occurrence;
5647 -- Raised : Boolean := False;
5649 if Exceptions_OK
then
5650 Blk_Decls
:= New_List
;
5651 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5655 Make_Block_Statement
(Loc
,
5656 Declarations
=> Blk_Decls
,
5657 Handled_Statement_Sequence
=>
5658 Make_Handled_Sequence_Of_Statements
(Loc
,
5659 Statements
=> Blk_Stmts
));
5662 -- Construct all necessary circuitry to hook and finalize a
5663 -- single transient object.
5665 Process_Transient_In_Scope
5666 (Obj_Decl
=> Obj_Decl
,
5667 Blk_Data
=> Blk_Data
,
5668 Blk_Stmts
=> Blk_Stmts
);
5671 -- Terminate the scan after the last object has been processed to
5672 -- avoid touching unrelated code.
5674 if Obj_Decl
= Last_Object
then
5681 -- Complete the decoration of the enclosing finalization block and
5682 -- insert it into the tree.
5684 if Present
(Blk_Decl
) then
5686 -- Note that this Abort_Undefer does not require a extra block or
5687 -- an AT_END handler because each finalization exception is caught
5688 -- in its own corresponding finalization block. As a result, the
5689 -- call to Abort_Defer always takes place.
5691 if Abort_Allowed
then
5692 Prepend_To
(Blk_Stmts
,
5693 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5695 Append_To
(Blk_Stmts
,
5696 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5700 -- if Raised and then not Abrt then
5701 -- Raise_From_Controlled_Operation (Ex);
5704 if Exceptions_OK
then
5705 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5708 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5710 end Process_Transients_In_Scope
;
5714 Loc
: constant Source_Ptr
:= Sloc
(N
);
5715 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5716 First_Obj
: Node_Id
;
5718 Mark_Id
: Entity_Id
;
5721 -- Start of processing for Insert_Actions_In_Scope_Around
5724 -- Nothing to do if the scope does not manage the secondary stack or
5725 -- does not contain meaninful actions for insertion.
5728 and then No
(Act_Before
)
5729 and then No
(Act_After
)
5730 and then No
(Act_Cleanup
)
5735 -- If the node to be wrapped is the trigger of an asynchronous select,
5736 -- it is not part of a statement list. The actions must be inserted
5737 -- before the select itself, which is part of some list of statements.
5738 -- Note that the triggering alternative includes the triggering
5739 -- statement and an optional statement list. If the node to be
5740 -- wrapped is part of that list, the normal insertion applies.
5742 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5743 and then not Is_List_Member
(Node_To_Wrap
)
5745 Target
:= Parent
(Parent
(Node_To_Wrap
));
5750 First_Obj
:= Target
;
5753 -- Add all actions associated with a transient scope into the main tree.
5754 -- There are several scenarios here:
5756 -- +--- Before ----+ +----- After ---+
5757 -- 1) First_Obj ....... Target ........ Last_Obj
5759 -- 2) First_Obj ....... Target
5761 -- 3) Target ........ Last_Obj
5763 -- Flag declarations are inserted before the first object
5765 if Present
(Act_Before
) then
5766 First_Obj
:= First
(Act_Before
);
5767 Insert_List_Before
(Target
, Act_Before
);
5770 -- Finalization calls are inserted after the last object
5772 if Present
(Act_After
) then
5773 Last_Obj
:= Last
(Act_After
);
5774 Insert_List_After
(Target
, Act_After
);
5777 -- Mark and release the secondary stack when the context warrants it
5780 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5783 -- Mnn : constant Mark_Id := SS_Mark;
5785 Insert_Before_And_Analyze
5786 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5789 -- SS_Release (Mnn);
5791 Insert_After_And_Analyze
5792 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5795 -- Check for transient objects associated with Target and generate the
5796 -- appropriate finalization actions for them.
5798 Process_Transients_In_Scope
5799 (First_Object
=> First_Obj
,
5800 Last_Object
=> Last_Obj
,
5801 Related_Node
=> Target
);
5803 -- Reset the action lists
5806 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5808 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5812 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5814 end Insert_Actions_In_Scope_Around
;
5816 ------------------------------
5817 -- Is_Simple_Protected_Type --
5818 ------------------------------
5820 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5823 Is_Protected_Type
(T
)
5824 and then not Uses_Lock_Free
(T
)
5825 and then not Has_Entries
(T
)
5826 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5827 end Is_Simple_Protected_Type
;
5829 -----------------------
5830 -- Make_Adjust_Call --
5831 -----------------------
5833 function Make_Adjust_Call
5836 Skip_Self
: Boolean := False) return Node_Id
5838 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5839 Adj_Id
: Entity_Id
:= Empty
;
5846 -- Recover the proper type which contains Deep_Adjust
5848 if Is_Class_Wide_Type
(Typ
) then
5849 Utyp
:= Root_Type
(Typ
);
5854 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5855 Set_Assignment_OK
(Ref
);
5857 -- Deal with untagged derivation of private views
5859 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5860 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5861 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5862 Set_Assignment_OK
(Ref
);
5865 -- When dealing with the completion of a private type, use the base
5868 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5869 pragma Assert
(Is_Private_Type
(Typ
));
5871 Utyp
:= Base_Type
(Utyp
);
5872 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5875 -- The underlying type may not be present due to a missing full view. In
5876 -- this case freezing did not take place and there is no [Deep_]Adjust
5877 -- primitive to call.
5882 elsif Skip_Self
then
5883 if Has_Controlled_Component
(Utyp
) then
5884 if Is_Tagged_Type
(Utyp
) then
5885 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5887 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5891 -- Class-wide types, interfaces and types with controlled components
5893 elsif Is_Class_Wide_Type
(Typ
)
5894 or else Is_Interface
(Typ
)
5895 or else Has_Controlled_Component
(Utyp
)
5897 if Is_Tagged_Type
(Utyp
) then
5898 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5900 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5903 -- Derivations from [Limited_]Controlled
5905 elsif Is_Controlled
(Utyp
) then
5906 if Has_Controlled_Component
(Utyp
) then
5907 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5909 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5914 elsif Is_Tagged_Type
(Utyp
) then
5915 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5918 raise Program_Error
;
5921 if Present
(Adj_Id
) then
5923 -- If the object is unanalyzed, set its expected type for use in
5924 -- Convert_View in case an additional conversion is needed.
5927 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5929 Set_Etype
(Ref
, Typ
);
5932 -- The object reference may need another conversion depending on the
5933 -- type of the formal and that of the actual.
5935 if not Is_Class_Wide_Type
(Typ
) then
5936 Ref
:= Convert_View
(Adj_Id
, Ref
);
5943 Skip_Self
=> Skip_Self
);
5947 end Make_Adjust_Call
;
5949 ----------------------
5950 -- Make_Detach_Call --
5951 ----------------------
5953 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5954 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5958 Make_Procedure_Call_Statement
(Loc
,
5960 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5961 Parameter_Associations
=> New_List
(
5962 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5963 end Make_Detach_Call
;
5971 Proc_Id
: Entity_Id
;
5973 Skip_Self
: Boolean := False) return Node_Id
5975 Params
: constant List_Id
:= New_List
(Param
);
5978 -- Do not apply the controlled action to the object itself by signaling
5979 -- the related routine to avoid self.
5982 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5986 Make_Procedure_Call_Statement
(Loc
,
5987 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5988 Parameter_Associations
=> Params
);
5991 --------------------------
5992 -- Make_Deep_Array_Body --
5993 --------------------------
5995 function Make_Deep_Array_Body
5996 (Prim
: Final_Primitives
;
5997 Typ
: Entity_Id
) return List_Id
5999 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
6001 function Build_Adjust_Or_Finalize_Statements
6002 (Typ
: Entity_Id
) return List_Id
;
6003 -- Create the statements necessary to adjust or finalize an array of
6004 -- controlled elements. Generate:
6007 -- Abort : constant Boolean := Triggered_By_Abort;
6009 -- Abort : constant Boolean := False; -- no abort
6011 -- E : Exception_Occurrence;
6012 -- Raised : Boolean := False;
6015 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6016 -- ^-- in the finalization case
6018 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6020 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6024 -- if not Raised then
6026 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6033 -- if Raised and then not Abort then
6034 -- Raise_From_Controlled_Operation (E);
6038 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6039 -- Create the statements necessary to initialize an array of controlled
6040 -- elements. Include a mechanism to carry out partial finalization if an
6041 -- exception occurs. Generate:
6044 -- Counter : Integer := 0;
6047 -- for J1 in V'Range (1) loop
6049 -- for JN in V'Range (N) loop
6051 -- [Deep_]Initialize (V (J1, ..., JN));
6053 -- Counter := Counter + 1;
6058 -- Abort : constant Boolean := Triggered_By_Abort;
6060 -- Abort : constant Boolean := False; -- no abort
6061 -- E : Exception_Occurrence;
6062 -- Raised : Boolean := False;
6069 -- V'Length (N) - Counter;
6071 -- for F1 in reverse V'Range (1) loop
6073 -- for FN in reverse V'Range (N) loop
6074 -- if Counter > 0 then
6075 -- Counter := Counter - 1;
6078 -- [Deep_]Finalize (V (F1, ..., FN));
6082 -- if not Raised then
6084 -- Save_Occurrence (E,
6085 -- Get_Current_Excep.all.all);
6094 -- if Raised and then not Abort then
6095 -- Raise_From_Controlled_Operation (E);
6104 function New_References_To
6106 Loc
: Source_Ptr
) return List_Id
;
6107 -- Given a list of defining identifiers, return a list of references to
6108 -- the original identifiers, in the same order as they appear.
6110 -----------------------------------------
6111 -- Build_Adjust_Or_Finalize_Statements --
6112 -----------------------------------------
6114 function Build_Adjust_Or_Finalize_Statements
6115 (Typ
: Entity_Id
) return List_Id
6117 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6118 Index_List
: constant List_Id
:= New_List
;
6119 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6120 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6122 procedure Build_Indexes
;
6123 -- Generate the indexes used in the dimension loops
6129 procedure Build_Indexes
is
6131 -- Generate the following identifiers:
6132 -- Jnn - for initialization
6134 for Dim
in 1 .. Num_Dims
loop
6135 Append_To
(Index_List
,
6136 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6142 Final_Decls
: List_Id
:= No_List
;
6143 Final_Data
: Finalization_Exception_Data
;
6147 Core_Loop
: Node_Id
;
6150 Loop_Id
: Entity_Id
;
6153 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6156 Final_Decls
:= New_List
;
6159 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6162 Make_Indexed_Component
(Loc
,
6163 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6164 Expressions
=> New_References_To
(Index_List
, Loc
));
6165 Set_Etype
(Comp_Ref
, Comp_Typ
);
6168 -- [Deep_]Adjust (V (J1, ..., JN))
6170 if Prim
= Adjust_Case
then
6171 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6174 -- [Deep_]Finalize (V (J1, ..., JN))
6176 else pragma Assert
(Prim
= Finalize_Case
);
6177 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6180 if Present
(Call
) then
6182 -- Generate the block which houses the adjust or finalize call:
6185 -- <adjust or finalize call>
6189 -- if not Raised then
6191 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6195 if Exceptions_OK
then
6197 Make_Block_Statement
(Loc
,
6198 Handled_Statement_Sequence
=>
6199 Make_Handled_Sequence_Of_Statements
(Loc
,
6200 Statements
=> New_List
(Call
),
6201 Exception_Handlers
=> New_List
(
6202 Build_Exception_Handler
(Final_Data
))));
6207 -- Generate the dimension loops starting from the innermost one
6209 -- for Jnn in [reverse] V'Range (Dim) loop
6213 J
:= Last
(Index_List
);
6215 while Present
(J
) and then Dim
> 0 loop
6221 Make_Loop_Statement
(Loc
,
6223 Make_Iteration_Scheme
(Loc
,
6224 Loop_Parameter_Specification
=>
6225 Make_Loop_Parameter_Specification
(Loc
,
6226 Defining_Identifier
=> Loop_Id
,
6227 Discrete_Subtype_Definition
=>
6228 Make_Attribute_Reference
(Loc
,
6229 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6230 Attribute_Name
=> Name_Range
,
6231 Expressions
=> New_List
(
6232 Make_Integer_Literal
(Loc
, Dim
))),
6235 Prim
= Finalize_Case
)),
6237 Statements
=> New_List
(Core_Loop
),
6238 End_Label
=> Empty
);
6243 -- Generate the block which contains the core loop, declarations
6244 -- of the abort flag, the exception occurrence, the raised flag
6245 -- and the conditional raise:
6248 -- Abort : constant Boolean := Triggered_By_Abort;
6250 -- Abort : constant Boolean := False; -- no abort
6252 -- E : Exception_Occurrence;
6253 -- Raised : Boolean := False;
6258 -- if Raised and then not Abort then
6259 -- Raise_From_Controlled_Operation (E);
6263 Stmts
:= New_List
(Core_Loop
);
6265 if Exceptions_OK
then
6266 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6270 Make_Block_Statement
(Loc
,
6271 Declarations
=> Final_Decls
,
6272 Handled_Statement_Sequence
=>
6273 Make_Handled_Sequence_Of_Statements
(Loc
,
6274 Statements
=> Stmts
));
6276 -- Otherwise previous errors or a missing full view may prevent the
6277 -- proper freezing of the component type. If this is the case, there
6278 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6281 Block
:= Make_Null_Statement
(Loc
);
6284 return New_List
(Block
);
6285 end Build_Adjust_Or_Finalize_Statements
;
6287 ---------------------------------
6288 -- Build_Initialize_Statements --
6289 ---------------------------------
6291 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6292 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6293 Final_List
: constant List_Id
:= New_List
;
6294 Index_List
: constant List_Id
:= New_List
;
6295 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6296 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6298 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6299 -- Generate the following assignment:
6300 -- Counter := V'Length (1) *
6302 -- V'Length (N) - Counter;
6304 -- Counter_Id denotes the entity of the counter.
6306 function Build_Finalization_Call
return Node_Id
;
6307 -- Generate a deep finalization call for an array element
6309 procedure Build_Indexes
;
6310 -- Generate the initialization and finalization indexes used in the
6313 function Build_Initialization_Call
return Node_Id
;
6314 -- Generate a deep initialization call for an array element
6316 ----------------------
6317 -- Build_Assignment --
6318 ----------------------
6320 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6325 -- Start from the first dimension and generate:
6330 Make_Attribute_Reference
(Loc
,
6331 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6332 Attribute_Name
=> Name_Length
,
6333 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6335 -- Process the rest of the dimensions, generate:
6336 -- Expr * V'Length (N)
6339 while Dim
<= Num_Dims
loop
6341 Make_Op_Multiply
(Loc
,
6344 Make_Attribute_Reference
(Loc
,
6345 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6346 Attribute_Name
=> Name_Length
,
6347 Expressions
=> New_List
(
6348 Make_Integer_Literal
(Loc
, Dim
))));
6354 -- Counter := Expr - Counter;
6357 Make_Assignment_Statement
(Loc
,
6358 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6360 Make_Op_Subtract
(Loc
,
6362 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6363 end Build_Assignment
;
6365 -----------------------------
6366 -- Build_Finalization_Call --
6367 -----------------------------
6369 function Build_Finalization_Call
return Node_Id
is
6370 Comp_Ref
: constant Node_Id
:=
6371 Make_Indexed_Component
(Loc
,
6372 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6373 Expressions
=> New_References_To
(Final_List
, Loc
));
6376 Set_Etype
(Comp_Ref
, Comp_Typ
);
6379 -- [Deep_]Finalize (V);
6381 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6382 end Build_Finalization_Call
;
6388 procedure Build_Indexes
is
6390 -- Generate the following identifiers:
6391 -- Jnn - for initialization
6392 -- Fnn - for finalization
6394 for Dim
in 1 .. Num_Dims
loop
6395 Append_To
(Index_List
,
6396 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6398 Append_To
(Final_List
,
6399 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6403 -------------------------------
6404 -- Build_Initialization_Call --
6405 -------------------------------
6407 function Build_Initialization_Call
return Node_Id
is
6408 Comp_Ref
: constant Node_Id
:=
6409 Make_Indexed_Component
(Loc
,
6410 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6411 Expressions
=> New_References_To
(Index_List
, Loc
));
6414 Set_Etype
(Comp_Ref
, Comp_Typ
);
6417 -- [Deep_]Initialize (V (J1, ..., JN));
6419 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6420 end Build_Initialization_Call
;
6424 Counter_Id
: Entity_Id
;
6428 Final_Block
: Node_Id
;
6429 Final_Data
: Finalization_Exception_Data
;
6430 Final_Decls
: List_Id
:= No_List
;
6431 Final_Loop
: Node_Id
;
6432 Init_Block
: Node_Id
;
6433 Init_Call
: Node_Id
;
6434 Init_Loop
: Node_Id
;
6439 -- Start of processing for Build_Initialize_Statements
6442 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6443 Final_Decls
:= New_List
;
6446 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6448 -- Generate the block which houses the finalization call, the index
6449 -- guard and the handler which triggers Program_Error later on.
6451 -- if Counter > 0 then
6452 -- Counter := Counter - 1;
6455 -- [Deep_]Finalize (V (F1, ..., FN));
6458 -- if not Raised then
6460 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6465 Fin_Stmt
:= Build_Finalization_Call
;
6467 if Present
(Fin_Stmt
) then
6468 if Exceptions_OK
then
6470 Make_Block_Statement
(Loc
,
6471 Handled_Statement_Sequence
=>
6472 Make_Handled_Sequence_Of_Statements
(Loc
,
6473 Statements
=> New_List
(Fin_Stmt
),
6474 Exception_Handlers
=> New_List
(
6475 Build_Exception_Handler
(Final_Data
))));
6478 -- This is the core of the loop, the dimension iterators are added
6479 -- one by one in reverse.
6482 Make_If_Statement
(Loc
,
6485 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6486 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6488 Then_Statements
=> New_List
(
6489 Make_Assignment_Statement
(Loc
,
6490 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6492 Make_Op_Subtract
(Loc
,
6493 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6494 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6496 Else_Statements
=> New_List
(Fin_Stmt
));
6498 -- Generate all finalization loops starting from the innermost
6501 -- for Fnn in reverse V'Range (Dim) loop
6505 F
:= Last
(Final_List
);
6507 while Present
(F
) and then Dim
> 0 loop
6513 Make_Loop_Statement
(Loc
,
6515 Make_Iteration_Scheme
(Loc
,
6516 Loop_Parameter_Specification
=>
6517 Make_Loop_Parameter_Specification
(Loc
,
6518 Defining_Identifier
=> Loop_Id
,
6519 Discrete_Subtype_Definition
=>
6520 Make_Attribute_Reference
(Loc
,
6521 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6522 Attribute_Name
=> Name_Range
,
6523 Expressions
=> New_List
(
6524 Make_Integer_Literal
(Loc
, Dim
))),
6526 Reverse_Present
=> True)),
6528 Statements
=> New_List
(Final_Loop
),
6529 End_Label
=> Empty
);
6534 -- Generate the block which contains the finalization loops, the
6535 -- declarations of the abort flag, the exception occurrence, the
6536 -- raised flag and the conditional raise.
6539 -- Abort : constant Boolean := Triggered_By_Abort;
6541 -- Abort : constant Boolean := False; -- no abort
6543 -- E : Exception_Occurrence;
6544 -- Raised : Boolean := False;
6550 -- V'Length (N) - Counter;
6554 -- if Raised and then not Abort then
6555 -- Raise_From_Controlled_Operation (E);
6561 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6563 if Exceptions_OK
then
6564 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6565 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6569 Make_Block_Statement
(Loc
,
6570 Declarations
=> Final_Decls
,
6571 Handled_Statement_Sequence
=>
6572 Make_Handled_Sequence_Of_Statements
(Loc
,
6573 Statements
=> Stmts
));
6575 -- Otherwise previous errors or a missing full view may prevent the
6576 -- proper freezing of the component type. If this is the case, there
6577 -- is no [Deep_]Finalize primitive to call.
6580 Final_Block
:= Make_Null_Statement
(Loc
);
6583 -- Generate the block which contains the initialization call and
6584 -- the partial finalization code.
6587 -- [Deep_]Initialize (V (J1, ..., JN));
6589 -- Counter := Counter + 1;
6593 -- <finalization code>
6596 Init_Call
:= Build_Initialization_Call
;
6598 -- Only create finalization block if there is a non-trivial
6599 -- call to initialization.
6601 if Present
(Init_Call
)
6602 and then Nkind
(Init_Call
) /= N_Null_Statement
6605 Make_Block_Statement
(Loc
,
6606 Handled_Statement_Sequence
=>
6607 Make_Handled_Sequence_Of_Statements
(Loc
,
6608 Statements
=> New_List
(Init_Call
),
6609 Exception_Handlers
=> New_List
(
6610 Make_Exception_Handler
(Loc
,
6611 Exception_Choices
=> New_List
(
6612 Make_Others_Choice
(Loc
)),
6613 Statements
=> New_List
(Final_Block
)))));
6615 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6616 Make_Assignment_Statement
(Loc
,
6617 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6620 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6621 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6623 -- Generate all initialization loops starting from the innermost
6626 -- for Jnn in V'Range (Dim) loop
6630 J
:= Last
(Index_List
);
6632 while Present
(J
) and then Dim
> 0 loop
6638 Make_Loop_Statement
(Loc
,
6640 Make_Iteration_Scheme
(Loc
,
6641 Loop_Parameter_Specification
=>
6642 Make_Loop_Parameter_Specification
(Loc
,
6643 Defining_Identifier
=> Loop_Id
,
6644 Discrete_Subtype_Definition
=>
6645 Make_Attribute_Reference
(Loc
,
6646 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6647 Attribute_Name
=> Name_Range
,
6648 Expressions
=> New_List
(
6649 Make_Integer_Literal
(Loc
, Dim
))))),
6651 Statements
=> New_List
(Init_Loop
),
6652 End_Label
=> Empty
);
6657 -- Generate the block which contains the counter variable and the
6658 -- initialization loops.
6661 -- Counter : Integer := 0;
6667 Make_Block_Statement
(Loc
,
6668 Declarations
=> New_List
(
6669 Make_Object_Declaration
(Loc
,
6670 Defining_Identifier
=> Counter_Id
,
6671 Object_Definition
=>
6672 New_Occurrence_Of
(Standard_Integer
, Loc
),
6673 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6675 Handled_Statement_Sequence
=>
6676 Make_Handled_Sequence_Of_Statements
(Loc
,
6677 Statements
=> New_List
(Init_Loop
)));
6679 -- Otherwise previous errors or a missing full view may prevent the
6680 -- proper freezing of the component type. If this is the case, there
6681 -- is no [Deep_]Initialize primitive to call.
6684 Init_Block
:= Make_Null_Statement
(Loc
);
6687 return New_List
(Init_Block
);
6688 end Build_Initialize_Statements
;
6690 -----------------------
6691 -- New_References_To --
6692 -----------------------
6694 function New_References_To
6696 Loc
: Source_Ptr
) return List_Id
6698 Refs
: constant List_Id
:= New_List
;
6703 while Present
(Id
) loop
6704 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6709 end New_References_To
;
6711 -- Start of processing for Make_Deep_Array_Body
6715 when Address_Case
=>
6716 return Make_Finalize_Address_Stmts
(Typ
);
6721 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6723 when Initialize_Case
=>
6724 return Build_Initialize_Statements
(Typ
);
6726 end Make_Deep_Array_Body
;
6728 --------------------
6729 -- Make_Deep_Proc --
6730 --------------------
6732 function Make_Deep_Proc
6733 (Prim
: Final_Primitives
;
6735 Stmts
: List_Id
) return Entity_Id
6737 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6739 Proc_Id
: Entity_Id
;
6742 -- Create the object formal, generate:
6743 -- V : System.Address
6745 if Prim
= Address_Case
then
6746 Formals
:= New_List
(
6747 Make_Parameter_Specification
(Loc
,
6748 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6750 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6757 Formals
:= New_List
(
6758 Make_Parameter_Specification
(Loc
,
6759 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6761 Out_Present
=> True,
6762 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6764 -- F : Boolean := True
6766 if Prim
= Adjust_Case
6767 or else Prim
= Finalize_Case
6770 Make_Parameter_Specification
(Loc
,
6771 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6773 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6775 New_Occurrence_Of
(Standard_True
, Loc
)));
6780 Make_Defining_Identifier
(Loc
,
6781 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6784 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6787 -- exception -- Finalize and Adjust cases only
6788 -- raise Program_Error;
6789 -- end Deep_Initialize / Adjust / Finalize;
6793 -- procedure Finalize_Address (V : System.Address) is
6796 -- end Finalize_Address;
6799 Make_Subprogram_Body
(Loc
,
6801 Make_Procedure_Specification
(Loc
,
6802 Defining_Unit_Name
=> Proc_Id
,
6803 Parameter_Specifications
=> Formals
),
6805 Declarations
=> Empty_List
,
6807 Handled_Statement_Sequence
=>
6808 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6810 -- If there are no calls to component initialization, indicate that
6811 -- the procedure is trivial, so prevent calls to it.
6813 if Is_Empty_List
(Stmts
)
6814 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6816 Set_Is_Trivial_Subprogram
(Proc_Id
);
6822 ---------------------------
6823 -- Make_Deep_Record_Body --
6824 ---------------------------
6826 function Make_Deep_Record_Body
6827 (Prim
: Final_Primitives
;
6829 Is_Local
: Boolean := False) return List_Id
6831 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
6833 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6834 -- Build the statements necessary to adjust a record type. The type may
6835 -- have discriminants and contain variant parts. Generate:
6839 -- [Deep_]Adjust (V.Comp_1);
6841 -- when Id : others =>
6842 -- if not Raised then
6844 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6849 -- [Deep_]Adjust (V.Comp_N);
6851 -- when Id : others =>
6852 -- if not Raised then
6854 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6859 -- Deep_Adjust (V._parent, False); -- If applicable
6861 -- when Id : others =>
6862 -- if not Raised then
6864 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6870 -- Adjust (V); -- If applicable
6873 -- if not Raised then
6875 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6880 -- if Raised and then not Abort then
6881 -- Raise_From_Controlled_Operation (E);
6885 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6886 -- Build the statements necessary to finalize a record type. The type
6887 -- may have discriminants and contain variant parts. Generate:
6890 -- Abort : constant Boolean := Triggered_By_Abort;
6892 -- Abort : constant Boolean := False; -- no abort
6893 -- E : Exception_Occurrence;
6894 -- Raised : Boolean := False;
6899 -- Finalize (V); -- If applicable
6902 -- if not Raised then
6904 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6909 -- case Variant_1 is
6911 -- case State_Counter_N => -- If Is_Local is enabled
6921 -- <<LN>> -- If Is_Local is enabled
6923 -- [Deep_]Finalize (V.Comp_N);
6926 -- if not Raised then
6928 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6934 -- [Deep_]Finalize (V.Comp_1);
6937 -- if not Raised then
6939 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6945 -- case State_Counter_1 => -- If Is_Local is enabled
6951 -- Deep_Finalize (V._parent, False); -- If applicable
6953 -- when Id : others =>
6954 -- if not Raised then
6956 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6960 -- if Raised and then not Abort then
6961 -- Raise_From_Controlled_Operation (E);
6965 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6966 -- Given a derived tagged type Typ, traverse all components, find field
6967 -- _parent and return its type.
6969 procedure Preprocess_Components
6971 Num_Comps
: out Nat
;
6972 Has_POC
: out Boolean);
6973 -- Examine all components in component list Comps, count all controlled
6974 -- components and determine whether at least one of them is per-object
6975 -- constrained. Component _parent is always skipped.
6977 -----------------------------
6978 -- Build_Adjust_Statements --
6979 -----------------------------
6981 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6982 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6983 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6985 Finalizer_Data
: Finalization_Exception_Data
;
6987 function Process_Component_List_For_Adjust
6988 (Comps
: Node_Id
) return List_Id
;
6989 -- Build all necessary adjust statements for a single component list
6991 ---------------------------------------
6992 -- Process_Component_List_For_Adjust --
6993 ---------------------------------------
6995 function Process_Component_List_For_Adjust
6996 (Comps
: Node_Id
) return List_Id
6998 Stmts
: constant List_Id
:= New_List
;
7000 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7001 -- Process the declaration of a single controlled component
7003 ----------------------------------
7004 -- Process_Component_For_Adjust --
7005 ----------------------------------
7007 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7008 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7009 Typ
: constant Entity_Id
:= Etype
(Id
);
7015 -- [Deep_]Adjust (V.Id);
7019 -- if not Raised then
7021 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7028 Make_Selected_Component
(Loc
,
7029 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7030 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7033 -- Guard against a missing [Deep_]Adjust when the component
7034 -- type was not properly frozen.
7036 if Present
(Adj_Call
) then
7037 if Exceptions_OK
then
7039 Make_Block_Statement
(Loc
,
7040 Handled_Statement_Sequence
=>
7041 Make_Handled_Sequence_Of_Statements
(Loc
,
7042 Statements
=> New_List
(Adj_Call
),
7043 Exception_Handlers
=> New_List
(
7044 Build_Exception_Handler
(Finalizer_Data
))));
7047 Append_To
(Stmts
, Adj_Call
);
7049 end Process_Component_For_Adjust
;
7054 Decl_Id
: Entity_Id
;
7055 Decl_Typ
: Entity_Id
;
7060 -- Start of processing for Process_Component_List_For_Adjust
7063 -- Perform an initial check, determine the number of controlled
7064 -- components in the current list and whether at least one of them
7065 -- is per-object constrained.
7067 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7069 -- The processing in this routine is done in the following order:
7070 -- 1) Regular components
7071 -- 2) Per-object constrained components
7074 if Num_Comps
> 0 then
7076 -- Process all regular components in order of declarations
7078 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7079 while Present
(Decl
) loop
7080 Decl_Id
:= Defining_Identifier
(Decl
);
7081 Decl_Typ
:= Etype
(Decl_Id
);
7083 -- Skip _parent as well as per-object constrained components
7085 if Chars
(Decl_Id
) /= Name_uParent
7086 and then Needs_Finalization
(Decl_Typ
)
7088 if Has_Access_Constraint
(Decl_Id
)
7089 and then No
(Expression
(Decl
))
7093 Process_Component_For_Adjust
(Decl
);
7097 Next_Non_Pragma
(Decl
);
7100 -- Process all per-object constrained components in order of
7104 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7105 while Present
(Decl
) loop
7106 Decl_Id
:= Defining_Identifier
(Decl
);
7107 Decl_Typ
:= Etype
(Decl_Id
);
7111 if Chars
(Decl_Id
) /= Name_uParent
7112 and then Needs_Finalization
(Decl_Typ
)
7113 and then Has_Access_Constraint
(Decl_Id
)
7114 and then No
(Expression
(Decl
))
7116 Process_Component_For_Adjust
(Decl
);
7119 Next_Non_Pragma
(Decl
);
7124 -- Process all variants, if any
7127 if Present
(Variant_Part
(Comps
)) then
7129 Var_Alts
: constant List_Id
:= New_List
;
7133 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7134 while Present
(Var
) loop
7137 -- when <discrete choices> =>
7138 -- <adjust statements>
7140 Append_To
(Var_Alts
,
7141 Make_Case_Statement_Alternative
(Loc
,
7143 New_Copy_List
(Discrete_Choices
(Var
)),
7145 Process_Component_List_For_Adjust
(
7146 Component_List
(Var
))));
7148 Next_Non_Pragma
(Var
);
7152 -- case V.<discriminant> is
7153 -- when <discrete choices 1> =>
7154 -- <adjust statements 1>
7156 -- when <discrete choices N> =>
7157 -- <adjust statements N>
7161 Make_Case_Statement
(Loc
,
7163 Make_Selected_Component
(Loc
,
7164 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7166 Make_Identifier
(Loc
,
7167 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7168 Alternatives
=> Var_Alts
);
7172 -- Add the variant case statement to the list of statements
7174 if Present
(Var_Case
) then
7175 Append_To
(Stmts
, Var_Case
);
7178 -- If the component list did not have any controlled components
7179 -- nor variants, return null.
7181 if Is_Empty_List
(Stmts
) then
7182 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7186 end Process_Component_List_For_Adjust
;
7190 Bod_Stmts
: List_Id
:= No_List
;
7191 Finalizer_Decls
: List_Id
:= No_List
;
7194 -- Start of processing for Build_Adjust_Statements
7197 Finalizer_Decls
:= New_List
;
7198 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7200 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7201 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7206 -- Create an adjust sequence for all record components
7208 if Present
(Component_List
(Rec_Def
)) then
7210 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7213 -- A derived record type must adjust all inherited components. This
7214 -- action poses the following problem:
7216 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7221 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7223 -- Deep_Adjust (Obj._parent);
7228 -- Adjusting the derived type will invoke Adjust of the parent and
7229 -- then that of the derived type. This is undesirable because both
7230 -- routines may modify shared components. Only the Adjust of the
7231 -- derived type should be invoked.
7233 -- To prevent this double adjustment of shared components,
7234 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7236 -- procedure Deep_Adjust
7237 -- (Obj : in out Some_Type;
7238 -- Flag : Boolean := True)
7246 -- When Deep_Adjust is invokes for field _parent, a value of False is
7247 -- provided for the flag:
7249 -- Deep_Adjust (Obj._parent, False);
7251 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7253 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7258 if Needs_Finalization
(Par_Typ
) then
7262 Make_Selected_Component
(Loc
,
7263 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7265 Make_Identifier
(Loc
, Name_uParent
)),
7271 -- Deep_Adjust (V._parent, False);
7274 -- when Id : others =>
7275 -- if not Raised then
7277 -- Save_Occurrence (E,
7278 -- Get_Current_Excep.all.all);
7282 if Present
(Call
) then
7285 if Exceptions_OK
then
7287 Make_Block_Statement
(Loc
,
7288 Handled_Statement_Sequence
=>
7289 Make_Handled_Sequence_Of_Statements
(Loc
,
7290 Statements
=> New_List
(Adj_Stmt
),
7291 Exception_Handlers
=> New_List
(
7292 Build_Exception_Handler
(Finalizer_Data
))));
7295 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7301 -- Adjust the object. This action must be performed last after all
7302 -- components have been adjusted.
7304 if Is_Controlled
(Typ
) then
7310 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7319 -- if not Raised then
7321 -- Save_Occurrence (E,
7322 -- Get_Current_Excep.all.all);
7327 if Present
(Proc
) then
7329 Make_Procedure_Call_Statement
(Loc
,
7330 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7331 Parameter_Associations
=> New_List
(
7332 Make_Identifier
(Loc
, Name_V
)));
7334 if Exceptions_OK
then
7336 Make_Block_Statement
(Loc
,
7337 Handled_Statement_Sequence
=>
7338 Make_Handled_Sequence_Of_Statements
(Loc
,
7339 Statements
=> New_List
(Adj_Stmt
),
7340 Exception_Handlers
=> New_List
(
7341 Build_Exception_Handler
7342 (Finalizer_Data
))));
7345 Append_To
(Bod_Stmts
,
7346 Make_If_Statement
(Loc
,
7347 Condition
=> Make_Identifier
(Loc
, Name_F
),
7348 Then_Statements
=> New_List
(Adj_Stmt
)));
7353 -- At this point either all adjustment statements have been generated
7354 -- or the type is not controlled.
7356 if Is_Empty_List
(Bod_Stmts
) then
7357 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7363 -- Abort : constant Boolean := Triggered_By_Abort;
7365 -- Abort : constant Boolean := False; -- no abort
7367 -- E : Exception_Occurrence;
7368 -- Raised : Boolean := False;
7371 -- <adjust statements>
7373 -- if Raised and then not Abort then
7374 -- Raise_From_Controlled_Operation (E);
7379 if Exceptions_OK
then
7380 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7385 Make_Block_Statement
(Loc
,
7388 Handled_Statement_Sequence
=>
7389 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7391 end Build_Adjust_Statements
;
7393 -------------------------------
7394 -- Build_Finalize_Statements --
7395 -------------------------------
7397 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7398 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7399 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7402 Finalizer_Data
: Finalization_Exception_Data
;
7404 function Process_Component_List_For_Finalize
7405 (Comps
: Node_Id
) return List_Id
;
7406 -- Build all necessary finalization statements for a single component
7407 -- list. The statements may include a jump circuitry if flag Is_Local
7410 -----------------------------------------
7411 -- Process_Component_List_For_Finalize --
7412 -----------------------------------------
7414 function Process_Component_List_For_Finalize
7415 (Comps
: Node_Id
) return List_Id
7417 procedure Process_Component_For_Finalize
7422 Num_Comps
: in out Nat
);
7423 -- Process the declaration of a single controlled component. If
7424 -- flag Is_Local is enabled, create the corresponding label and
7425 -- jump circuitry. Alts is the list of case alternatives, Decls
7426 -- is the top level declaration list where labels are declared
7427 -- and Stmts is the list of finalization actions. Num_Comps
7428 -- denotes the current number of components needing finalization.
7430 ------------------------------------
7431 -- Process_Component_For_Finalize --
7432 ------------------------------------
7434 procedure Process_Component_For_Finalize
7439 Num_Comps
: in out Nat
)
7441 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7442 Typ
: constant Entity_Id
:= Etype
(Id
);
7449 Label_Id
: Entity_Id
;
7456 Make_Identifier
(Loc
,
7457 Chars
=> New_External_Name
('L', Num_Comps
));
7458 Set_Entity
(Label_Id
,
7459 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7460 Label
:= Make_Label
(Loc
, Label_Id
);
7463 Make_Implicit_Label_Declaration
(Loc
,
7464 Defining_Identifier
=> Entity
(Label_Id
),
7465 Label_Construct
=> Label
));
7472 Make_Case_Statement_Alternative
(Loc
,
7473 Discrete_Choices
=> New_List
(
7474 Make_Integer_Literal
(Loc
, Num_Comps
)),
7476 Statements
=> New_List
(
7477 Make_Goto_Statement
(Loc
,
7479 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7484 Append_To
(Stmts
, Label
);
7486 -- Decrease the number of components to be processed.
7487 -- This action yields a new Label_Id in future calls.
7489 Num_Comps
:= Num_Comps
- 1;
7494 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7496 -- begin -- Exception handlers allowed
7497 -- [Deep_]Finalize (V.Id);
7500 -- if not Raised then
7502 -- Save_Occurrence (E,
7503 -- Get_Current_Excep.all.all);
7510 Make_Selected_Component
(Loc
,
7511 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7512 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7515 -- Guard against a missing [Deep_]Finalize when the component
7516 -- type was not properly frozen.
7518 if Present
(Fin_Call
) then
7519 if Exceptions_OK
then
7521 Make_Block_Statement
(Loc
,
7522 Handled_Statement_Sequence
=>
7523 Make_Handled_Sequence_Of_Statements
(Loc
,
7524 Statements
=> New_List
(Fin_Call
),
7525 Exception_Handlers
=> New_List
(
7526 Build_Exception_Handler
(Finalizer_Data
))));
7529 Append_To
(Stmts
, Fin_Call
);
7531 end Process_Component_For_Finalize
;
7536 Counter_Id
: Entity_Id
:= Empty
;
7538 Decl_Id
: Entity_Id
;
7539 Decl_Typ
: Entity_Id
;
7542 Jump_Block
: Node_Id
;
7544 Label_Id
: Entity_Id
;
7549 -- Start of processing for Process_Component_List_For_Finalize
7552 -- Perform an initial check, look for controlled and per-object
7553 -- constrained components.
7555 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7557 -- Create a state counter to service the current component list.
7558 -- This step is performed before the variants are inspected in
7559 -- order to generate the same state counter names as those from
7560 -- Build_Initialize_Statements.
7562 if Num_Comps
> 0 and then Is_Local
then
7563 Counter
:= Counter
+ 1;
7566 Make_Defining_Identifier
(Loc
,
7567 Chars
=> New_External_Name
('C', Counter
));
7570 -- Process the component in the following order:
7572 -- 2) Per-object constrained components
7573 -- 3) Regular components
7575 -- Start with the variant parts
7578 if Present
(Variant_Part
(Comps
)) then
7580 Var_Alts
: constant List_Id
:= New_List
;
7584 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7585 while Present
(Var
) loop
7588 -- when <discrete choices> =>
7589 -- <finalize statements>
7591 Append_To
(Var_Alts
,
7592 Make_Case_Statement_Alternative
(Loc
,
7594 New_Copy_List
(Discrete_Choices
(Var
)),
7596 Process_Component_List_For_Finalize
(
7597 Component_List
(Var
))));
7599 Next_Non_Pragma
(Var
);
7603 -- case V.<discriminant> is
7604 -- when <discrete choices 1> =>
7605 -- <finalize statements 1>
7607 -- when <discrete choices N> =>
7608 -- <finalize statements N>
7612 Make_Case_Statement
(Loc
,
7614 Make_Selected_Component
(Loc
,
7615 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7617 Make_Identifier
(Loc
,
7618 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7619 Alternatives
=> Var_Alts
);
7623 -- The current component list does not have a single controlled
7624 -- component, however it may contain variants. Return the case
7625 -- statement for the variants or nothing.
7627 if Num_Comps
= 0 then
7628 if Present
(Var_Case
) then
7629 return New_List
(Var_Case
);
7631 return New_List
(Make_Null_Statement
(Loc
));
7635 -- Prepare all lists
7641 -- Process all per-object constrained components in reverse order
7644 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7645 while Present
(Decl
) loop
7646 Decl_Id
:= Defining_Identifier
(Decl
);
7647 Decl_Typ
:= Etype
(Decl_Id
);
7651 if Chars
(Decl_Id
) /= Name_uParent
7652 and then Needs_Finalization
(Decl_Typ
)
7653 and then Has_Access_Constraint
(Decl_Id
)
7654 and then No
(Expression
(Decl
))
7656 Process_Component_For_Finalize
7657 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7660 Prev_Non_Pragma
(Decl
);
7664 -- Process the rest of the components in reverse order
7666 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7667 while Present
(Decl
) loop
7668 Decl_Id
:= Defining_Identifier
(Decl
);
7669 Decl_Typ
:= Etype
(Decl_Id
);
7673 if Chars
(Decl_Id
) /= Name_uParent
7674 and then Needs_Finalization
(Decl_Typ
)
7676 -- Skip per-object constrained components since they were
7677 -- handled in the above step.
7679 if Has_Access_Constraint
(Decl_Id
)
7680 and then No
(Expression
(Decl
))
7684 Process_Component_For_Finalize
7685 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7689 Prev_Non_Pragma
(Decl
);
7694 -- LN : label; -- If Is_Local is enabled
7699 -- case CounterX is .
7709 -- <<LN>> -- If Is_Local is enabled
7711 -- [Deep_]Finalize (V.CompY);
7713 -- when Id : others =>
7714 -- if not Raised then
7716 -- Save_Occurrence (E,
7717 -- Get_Current_Excep.all.all);
7721 -- <<L0>> -- If Is_Local is enabled
7726 -- Add the declaration of default jump location L0, its
7727 -- corresponding alternative and its place in the statements.
7729 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7730 Set_Entity
(Label_Id
,
7731 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7732 Label
:= Make_Label
(Loc
, Label_Id
);
7734 Append_To
(Decls
, -- declaration
7735 Make_Implicit_Label_Declaration
(Loc
,
7736 Defining_Identifier
=> Entity
(Label_Id
),
7737 Label_Construct
=> Label
));
7739 Append_To
(Alts
, -- alternative
7740 Make_Case_Statement_Alternative
(Loc
,
7741 Discrete_Choices
=> New_List
(
7742 Make_Others_Choice
(Loc
)),
7744 Statements
=> New_List
(
7745 Make_Goto_Statement
(Loc
,
7746 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7748 Append_To
(Stmts
, Label
); -- statement
7750 -- Create the jump block
7753 Make_Case_Statement
(Loc
,
7754 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7755 Alternatives
=> Alts
));
7759 Make_Block_Statement
(Loc
,
7760 Declarations
=> Decls
,
7761 Handled_Statement_Sequence
=>
7762 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7764 if Present
(Var_Case
) then
7765 return New_List
(Var_Case
, Jump_Block
);
7767 return New_List
(Jump_Block
);
7769 end Process_Component_List_For_Finalize
;
7773 Bod_Stmts
: List_Id
:= No_List
;
7774 Finalizer_Decls
: List_Id
:= No_List
;
7777 -- Start of processing for Build_Finalize_Statements
7780 Finalizer_Decls
:= New_List
;
7781 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7783 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7784 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7789 -- Create a finalization sequence for all record components
7791 if Present
(Component_List
(Rec_Def
)) then
7793 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7796 -- A derived record type must finalize all inherited components. This
7797 -- action poses the following problem:
7799 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7804 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7806 -- Deep_Finalize (Obj._parent);
7811 -- Finalizing the derived type will invoke Finalize of the parent and
7812 -- then that of the derived type. This is undesirable because both
7813 -- routines may modify shared components. Only the Finalize of the
7814 -- derived type should be invoked.
7816 -- To prevent this double adjustment of shared components,
7817 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7819 -- procedure Deep_Finalize
7820 -- (Obj : in out Some_Type;
7821 -- Flag : Boolean := True)
7829 -- When Deep_Finalize is invoked for field _parent, a value of False
7830 -- is provided for the flag:
7832 -- Deep_Finalize (Obj._parent, False);
7834 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7836 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7841 if Needs_Finalization
(Par_Typ
) then
7845 Make_Selected_Component
(Loc
,
7846 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7848 Make_Identifier
(Loc
, Name_uParent
)),
7854 -- Deep_Finalize (V._parent, False);
7857 -- when Id : others =>
7858 -- if not Raised then
7860 -- Save_Occurrence (E,
7861 -- Get_Current_Excep.all.all);
7865 if Present
(Call
) then
7868 if Exceptions_OK
then
7870 Make_Block_Statement
(Loc
,
7871 Handled_Statement_Sequence
=>
7872 Make_Handled_Sequence_Of_Statements
(Loc
,
7873 Statements
=> New_List
(Fin_Stmt
),
7874 Exception_Handlers
=> New_List
(
7875 Build_Exception_Handler
7876 (Finalizer_Data
))));
7879 Append_To
(Bod_Stmts
, Fin_Stmt
);
7885 -- Finalize the object. This action must be performed first before
7886 -- all components have been finalized.
7888 if Is_Controlled
(Typ
) and then not Is_Local
then
7894 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7903 -- if not Raised then
7905 -- Save_Occurrence (E,
7906 -- Get_Current_Excep.all.all);
7911 if Present
(Proc
) then
7913 Make_Procedure_Call_Statement
(Loc
,
7914 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7915 Parameter_Associations
=> New_List
(
7916 Make_Identifier
(Loc
, Name_V
)));
7918 if Exceptions_OK
then
7920 Make_Block_Statement
(Loc
,
7921 Handled_Statement_Sequence
=>
7922 Make_Handled_Sequence_Of_Statements
(Loc
,
7923 Statements
=> New_List
(Fin_Stmt
),
7924 Exception_Handlers
=> New_List
(
7925 Build_Exception_Handler
7926 (Finalizer_Data
))));
7929 Prepend_To
(Bod_Stmts
,
7930 Make_If_Statement
(Loc
,
7931 Condition
=> Make_Identifier
(Loc
, Name_F
),
7932 Then_Statements
=> New_List
(Fin_Stmt
)));
7937 -- At this point either all finalization statements have been
7938 -- generated or the type is not controlled.
7940 if No
(Bod_Stmts
) then
7941 return New_List
(Make_Null_Statement
(Loc
));
7945 -- Abort : constant Boolean := Triggered_By_Abort;
7947 -- Abort : constant Boolean := False; -- no abort
7949 -- E : Exception_Occurrence;
7950 -- Raised : Boolean := False;
7953 -- <finalize statements>
7955 -- if Raised and then not Abort then
7956 -- Raise_From_Controlled_Operation (E);
7961 if Exceptions_OK
then
7962 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7967 Make_Block_Statement
(Loc
,
7970 Handled_Statement_Sequence
=>
7971 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7973 end Build_Finalize_Statements
;
7975 -----------------------
7976 -- Parent_Field_Type --
7977 -----------------------
7979 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7983 Field
:= First_Entity
(Typ
);
7984 while Present
(Field
) loop
7985 if Chars
(Field
) = Name_uParent
then
7986 return Etype
(Field
);
7989 Next_Entity
(Field
);
7992 -- A derived tagged type should always have a parent field
7994 raise Program_Error
;
7995 end Parent_Field_Type
;
7997 ---------------------------
7998 -- Preprocess_Components --
7999 ---------------------------
8001 procedure Preprocess_Components
8003 Num_Comps
: out Nat
;
8004 Has_POC
: out Boolean)
8014 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8015 while Present
(Decl
) loop
8016 Id
:= Defining_Identifier
(Decl
);
8019 -- Skip field _parent
8021 if Chars
(Id
) /= Name_uParent
8022 and then Needs_Finalization
(Typ
)
8024 Num_Comps
:= Num_Comps
+ 1;
8026 if Has_Access_Constraint
(Id
)
8027 and then No
(Expression
(Decl
))
8033 Next_Non_Pragma
(Decl
);
8035 end Preprocess_Components
;
8037 -- Start of processing for Make_Deep_Record_Body
8041 when Address_Case
=>
8042 return Make_Finalize_Address_Stmts
(Typ
);
8045 return Build_Adjust_Statements
(Typ
);
8047 when Finalize_Case
=>
8048 return Build_Finalize_Statements
(Typ
);
8050 when Initialize_Case
=>
8052 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8055 if Is_Controlled
(Typ
) then
8057 Make_Procedure_Call_Statement
(Loc
,
8060 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8061 Parameter_Associations
=> New_List
(
8062 Make_Identifier
(Loc
, Name_V
))));
8068 end Make_Deep_Record_Body
;
8070 ----------------------
8071 -- Make_Final_Call --
8072 ----------------------
8074 function Make_Final_Call
8077 Skip_Self
: Boolean := False) return Node_Id
8079 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8081 Fin_Id
: Entity_Id
:= Empty
;
8088 -- Recover the proper type which contains [Deep_]Finalize
8090 if Is_Class_Wide_Type
(Typ
) then
8091 Utyp
:= Root_Type
(Typ
);
8094 elsif Is_Concurrent_Type
(Typ
) then
8095 Utyp
:= Corresponding_Record_Type
(Typ
);
8097 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8099 elsif Is_Private_Type
(Typ
)
8100 and then Present
(Full_View
(Typ
))
8101 and then Is_Concurrent_Type
(Full_View
(Typ
))
8103 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
8105 Ref
:= Convert_Concurrent
(Ref
, Full_View
(Typ
));
8112 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8113 Set_Assignment_OK
(Ref
);
8115 -- Deal with untagged derivation of private views. If the parent type
8116 -- is a protected type, Deep_Finalize is found on the corresponding
8117 -- record of the ancestor.
8119 if Is_Untagged_Derivation
(Typ
) then
8120 if Is_Protected_Type
(Typ
) then
8121 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8123 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8125 if Is_Protected_Type
(Utyp
) then
8126 Utyp
:= Corresponding_Record_Type
(Utyp
);
8130 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8131 Set_Assignment_OK
(Ref
);
8134 -- Deal with derived private types which do not inherit primitives from
8135 -- their parents. In this case, [Deep_]Finalize can be found in the full
8136 -- view of the parent type.
8139 and then Is_Tagged_Type
(Utyp
)
8140 and then Is_Derived_Type
(Utyp
)
8141 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8142 and then Is_Private_Type
(Etype
(Utyp
))
8143 and then Present
(Full_View
(Etype
(Utyp
)))
8145 Utyp
:= Full_View
(Etype
(Utyp
));
8146 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8147 Set_Assignment_OK
(Ref
);
8150 -- When dealing with the completion of a private type, use the base type
8153 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8154 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8156 Utyp
:= Base_Type
(Utyp
);
8157 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8158 Set_Assignment_OK
(Ref
);
8161 -- The underlying type may not be present due to a missing full view. In
8162 -- this case freezing did not take place and there is no [Deep_]Finalize
8163 -- primitive to call.
8168 elsif Skip_Self
then
8169 if Has_Controlled_Component
(Utyp
) then
8170 if Is_Tagged_Type
(Utyp
) then
8171 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8173 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8177 -- Class-wide types, interfaces and types with controlled components
8179 elsif Is_Class_Wide_Type
(Typ
)
8180 or else Is_Interface
(Typ
)
8181 or else Has_Controlled_Component
(Utyp
)
8183 if Is_Tagged_Type
(Utyp
) then
8184 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8186 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8189 -- Derivations from [Limited_]Controlled
8191 elsif Is_Controlled
(Utyp
) then
8192 if Has_Controlled_Component
(Utyp
) then
8193 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8195 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8200 elsif Is_Tagged_Type
(Utyp
) then
8201 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8204 raise Program_Error
;
8207 if Present
(Fin_Id
) then
8209 -- When finalizing a class-wide object, do not convert to the root
8210 -- type in order to produce a dispatching call.
8212 if Is_Class_Wide_Type
(Typ
) then
8215 -- Ensure that a finalization routine is at least decorated in order
8216 -- to inspect the object parameter.
8218 elsif Analyzed
(Fin_Id
)
8219 or else Ekind
(Fin_Id
) = E_Procedure
8221 -- In certain cases, such as the creation of Stream_Read, the
8222 -- visible entity of the type is its full view. Since Stream_Read
8223 -- will have to create an object of type Typ, the local object
8224 -- will be finalzed by the scope finalizer generated later on. The
8225 -- object parameter of Deep_Finalize will always use the private
8226 -- view of the type. To avoid such a clash between a private and a
8227 -- full view, perform an unchecked conversion of the object
8228 -- reference to the private view.
8231 Formal_Typ
: constant Entity_Id
:=
8232 Etype
(First_Formal
(Fin_Id
));
8234 if Is_Private_Type
(Formal_Typ
)
8235 and then Present
(Full_View
(Formal_Typ
))
8236 and then Full_View
(Formal_Typ
) = Utyp
8238 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8242 Ref
:= Convert_View
(Fin_Id
, Ref
);
8249 Skip_Self
=> Skip_Self
);
8253 end Make_Final_Call
;
8255 --------------------------------
8256 -- Make_Finalize_Address_Body --
8257 --------------------------------
8259 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8260 Is_Task
: constant Boolean :=
8261 Ekind
(Typ
) = E_Record_Type
8262 and then Is_Concurrent_Record_Type
(Typ
)
8263 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8265 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8266 Proc_Id
: Entity_Id
;
8270 -- The corresponding records of task types are not controlled by design.
8271 -- For the sake of completeness, create an empty Finalize_Address to be
8272 -- used in task class-wide allocations.
8277 -- Nothing to do if the type is not controlled or it already has a
8278 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8279 -- come from source. These are usually generated for completeness and
8280 -- do not need the Finalize_Address primitive.
8282 elsif not Needs_Finalization
(Typ
)
8283 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8285 (Is_Class_Wide_Type
(Typ
)
8286 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8287 and then not Comes_From_Source
(Root_Type
(Typ
)))
8292 -- Do not generate Finalize_Address routine for CodePeer
8294 if CodePeer_Mode
then
8299 Make_Defining_Identifier
(Loc
,
8300 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8304 -- procedure <Typ>FD (V : System.Address) is
8306 -- null; -- for tasks
8308 -- declare -- for all other types
8309 -- type Pnn is access all Typ;
8310 -- for Pnn'Storage_Size use 0;
8312 -- [Deep_]Finalize (Pnn (V).all);
8317 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8319 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8323 Make_Subprogram_Body
(Loc
,
8325 Make_Procedure_Specification
(Loc
,
8326 Defining_Unit_Name
=> Proc_Id
,
8328 Parameter_Specifications
=> New_List
(
8329 Make_Parameter_Specification
(Loc
,
8330 Defining_Identifier
=>
8331 Make_Defining_Identifier
(Loc
, Name_V
),
8333 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8335 Declarations
=> No_List
,
8337 Handled_Statement_Sequence
=>
8338 Make_Handled_Sequence_Of_Statements
(Loc
,
8339 Statements
=> Stmts
)));
8341 Set_TSS
(Typ
, Proc_Id
);
8342 end Make_Finalize_Address_Body
;
8344 ---------------------------------
8345 -- Make_Finalize_Address_Stmts --
8346 ---------------------------------
8348 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8349 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8352 Desig_Typ
: Entity_Id
;
8353 Fin_Block
: Node_Id
;
8356 Ptr_Typ
: Entity_Id
;
8359 if Is_Array_Type
(Typ
) then
8360 if Is_Constrained
(First_Subtype
(Typ
)) then
8361 Desig_Typ
:= First_Subtype
(Typ
);
8363 Desig_Typ
:= Base_Type
(Typ
);
8366 -- Class-wide types of constrained root types
8368 elsif Is_Class_Wide_Type
(Typ
)
8369 and then Has_Discriminants
(Root_Type
(Typ
))
8371 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8374 Parent_Typ
: Entity_Id
;
8377 -- Climb the parent type chain looking for a non-constrained type
8379 Parent_Typ
:= Root_Type
(Typ
);
8380 while Parent_Typ
/= Etype
(Parent_Typ
)
8381 and then Has_Discriminants
(Parent_Typ
)
8383 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8385 Parent_Typ
:= Etype
(Parent_Typ
);
8388 -- Handle views created for tagged types with unknown
8391 if Is_Underlying_Record_View
(Parent_Typ
) then
8392 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8395 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
8405 -- type Ptr_Typ is access all Typ;
8406 -- for Ptr_Typ'Storage_Size use 0;
8408 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8411 Make_Full_Type_Declaration
(Loc
,
8412 Defining_Identifier
=> Ptr_Typ
,
8414 Make_Access_To_Object_Definition
(Loc
,
8415 All_Present
=> True,
8416 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8418 Make_Attribute_Definition_Clause
(Loc
,
8419 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8420 Chars
=> Name_Storage_Size
,
8421 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8423 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8425 -- Unconstrained arrays require special processing in order to retrieve
8426 -- the elements. To achieve this, we have to skip the dope vector which
8427 -- lays in front of the elements and then use a thin pointer to perform
8428 -- the address-to-access conversion.
8430 if Is_Array_Type
(Typ
)
8431 and then not Is_Constrained
(First_Subtype
(Typ
))
8434 Dope_Id
: Entity_Id
;
8437 -- Ensure that Ptr_Typ a thin pointer, generate:
8438 -- for Ptr_Typ'Size use System.Address'Size;
8441 Make_Attribute_Definition_Clause
(Loc
,
8442 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8445 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8448 -- Dnn : constant Storage_Offset :=
8449 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8451 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8454 Make_Object_Declaration
(Loc
,
8455 Defining_Identifier
=> Dope_Id
,
8456 Constant_Present
=> True,
8457 Object_Definition
=>
8458 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8460 Make_Op_Divide
(Loc
,
8462 Make_Attribute_Reference
(Loc
,
8463 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8464 Attribute_Name
=> Name_Descriptor_Size
),
8466 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8468 -- Shift the address from the start of the dope vector to the
8469 -- start of the elements:
8473 -- Note that this is done through a wrapper routine since RTSfind
8474 -- cannot retrieve operations with string names of the form "+".
8477 Make_Function_Call
(Loc
,
8479 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8480 Parameter_Associations
=> New_List
(
8482 New_Occurrence_Of
(Dope_Id
, Loc
)));
8489 Make_Explicit_Dereference
(Loc
,
8490 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8493 if Present
(Fin_Call
) then
8495 Make_Block_Statement
(Loc
,
8496 Declarations
=> Decls
,
8497 Handled_Statement_Sequence
=>
8498 Make_Handled_Sequence_Of_Statements
(Loc
,
8499 Statements
=> New_List
(Fin_Call
)));
8501 -- Otherwise previous errors or a missing full view may prevent the
8502 -- proper freezing of the designated type. If this is the case, there
8503 -- is no [Deep_]Finalize primitive to call.
8506 Fin_Block
:= Make_Null_Statement
(Loc
);
8509 return New_List
(Fin_Block
);
8510 end Make_Finalize_Address_Stmts
;
8512 -------------------------------------
8513 -- Make_Handler_For_Ctrl_Operation --
8514 -------------------------------------
8518 -- when E : others =>
8519 -- Raise_From_Controlled_Operation (E);
8524 -- raise Program_Error [finalize raised exception];
8526 -- depending on whether Raise_From_Controlled_Operation is available
8528 function Make_Handler_For_Ctrl_Operation
8529 (Loc
: Source_Ptr
) return Node_Id
8532 -- Choice parameter (for the first case above)
8534 Raise_Node
: Node_Id
;
8535 -- Procedure call or raise statement
8538 -- Standard run-time: add choice parameter E and pass it to
8539 -- Raise_From_Controlled_Operation so that the original exception
8540 -- name and message can be recorded in the exception message for
8543 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8544 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8546 Make_Procedure_Call_Statement
(Loc
,
8549 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8550 Parameter_Associations
=> New_List
(
8551 New_Occurrence_Of
(E_Occ
, Loc
)));
8553 -- Restricted run-time: exception messages are not supported
8558 Make_Raise_Program_Error
(Loc
,
8559 Reason
=> PE_Finalize_Raised_Exception
);
8563 Make_Implicit_Exception_Handler
(Loc
,
8564 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8565 Choice_Parameter
=> E_Occ
,
8566 Statements
=> New_List
(Raise_Node
));
8567 end Make_Handler_For_Ctrl_Operation
;
8569 --------------------
8570 -- Make_Init_Call --
8571 --------------------
8573 function Make_Init_Call
8575 Typ
: Entity_Id
) return Node_Id
8577 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8586 -- Deal with the type and object reference. Depending on the context, an
8587 -- object reference may need several conversions.
8589 if Is_Concurrent_Type
(Typ
) then
8591 Utyp
:= Corresponding_Record_Type
(Typ
);
8592 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8594 elsif Is_Private_Type
(Typ
)
8595 and then Present
(Full_View
(Typ
))
8596 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8599 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8600 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8607 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8608 Set_Assignment_OK
(Ref
);
8610 -- Deal with untagged derivation of private views
8612 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8613 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8614 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8616 -- The following is to prevent problems with UC see 1.156 RH ???
8618 Set_Assignment_OK
(Ref
);
8621 -- If the underlying_type is a subtype, then we are dealing with the
8622 -- completion of a private type. We need to access the base type and
8623 -- generate a conversion to it.
8625 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8626 pragma Assert
(Is_Private_Type
(Typ
));
8627 Utyp
:= Base_Type
(Utyp
);
8628 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8631 -- The underlying type may not be present due to a missing full view.
8632 -- In this case freezing did not take place and there is no suitable
8633 -- [Deep_]Initialize primitive to call.
8639 -- Select the appropriate version of initialize
8641 if Has_Controlled_Component
(Utyp
) then
8642 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8644 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8645 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8648 -- If initialization procedure for an array of controlled objects is
8649 -- trivial, do not generate a useless call to it.
8651 if (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8653 (not Comes_From_Source
(Proc
)
8654 and then Present
(Alias
(Proc
))
8655 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8657 return Make_Null_Statement
(Loc
);
8660 -- The object reference may need another conversion depending on the
8661 -- type of the formal and that of the actual.
8663 Ref
:= Convert_View
(Proc
, Ref
);
8666 -- [Deep_]Initialize (Ref);
8669 Make_Procedure_Call_Statement
(Loc
,
8670 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8671 Parameter_Associations
=> New_List
(Ref
));
8674 ------------------------------
8675 -- Make_Local_Deep_Finalize --
8676 ------------------------------
8678 function Make_Local_Deep_Finalize
8680 Nam
: Entity_Id
) return Node_Id
8682 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8686 Formals
:= New_List
(
8690 Make_Parameter_Specification
(Loc
,
8691 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8693 Out_Present
=> True,
8694 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8696 -- F : Boolean := True
8698 Make_Parameter_Specification
(Loc
,
8699 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8700 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8701 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8703 -- Add the necessary number of counters to represent the initialization
8704 -- state of an object.
8707 Make_Subprogram_Body
(Loc
,
8709 Make_Procedure_Specification
(Loc
,
8710 Defining_Unit_Name
=> Nam
,
8711 Parameter_Specifications
=> Formals
),
8713 Declarations
=> No_List
,
8715 Handled_Statement_Sequence
=>
8716 Make_Handled_Sequence_Of_Statements
(Loc
,
8717 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8718 end Make_Local_Deep_Finalize
;
8720 ------------------------------------
8721 -- Make_Set_Finalize_Address_Call --
8722 ------------------------------------
8724 function Make_Set_Finalize_Address_Call
8726 Ptr_Typ
: Entity_Id
) return Node_Id
8728 -- It is possible for Ptr_Typ to be a partial view, if the access type
8729 -- is a full view declared in the private part of a nested package, and
8730 -- the finalization actions take place when completing analysis of the
8731 -- enclosing unit. For this reason use Underlying_Type twice below.
8733 Desig_Typ
: constant Entity_Id
:=
8735 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8736 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8737 Fin_Mas
: constant Entity_Id
:=
8738 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8741 -- Both the finalization master and primitive Finalize_Address must be
8744 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8747 -- Set_Finalize_Address
8748 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8751 Make_Procedure_Call_Statement
(Loc
,
8753 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8754 Parameter_Associations
=> New_List
(
8755 New_Occurrence_Of
(Fin_Mas
, Loc
),
8757 Make_Attribute_Reference
(Loc
,
8758 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8759 Attribute_Name
=> Name_Unrestricted_Access
)));
8760 end Make_Set_Finalize_Address_Call
;
8762 --------------------------
8763 -- Make_Transient_Block --
8764 --------------------------
8766 function Make_Transient_Block
8769 Par
: Node_Id
) return Node_Id
8771 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8772 -- Determine whether scoping entity Id manages the secondary stack
8774 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
8775 -- Return True when N appears within a loop and no block is containing N
8777 -----------------------
8778 -- Manages_Sec_Stack --
8779 -----------------------
8781 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8785 -- An exception handler with a choice parameter utilizes a dummy
8786 -- block to provide a declarative region. Such a block should not
8787 -- be considered because it never manifests in the tree and can
8788 -- never release the secondary stack.
8792 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8799 return Uses_Sec_Stack
(Id
);
8804 end Manages_Sec_Stack
;
8806 ---------------------------
8807 -- Within_Loop_Statement --
8808 ---------------------------
8810 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
8811 Par
: Node_Id
:= Parent
(N
);
8814 while not (Nkind_In
(Par
, N_Handled_Sequence_Of_Statements
,
8816 N_Package_Specification
)
8817 or else Nkind
(Par
) in N_Proper_Body
)
8819 pragma Assert
(Present
(Par
));
8820 Par
:= Parent
(Par
);
8823 return Nkind
(Par
) = N_Loop_Statement
;
8824 end Within_Loop_Statement
;
8828 Decls
: constant List_Id
:= New_List
;
8829 Instrs
: constant List_Id
:= New_List
(Action
);
8830 Trans_Id
: constant Entity_Id
:= Current_Scope
;
8836 -- Start of processing for Make_Transient_Block
8839 -- Even though the transient block is tasked with managing the secondary
8840 -- stack, the block may forgo this functionality depending on how the
8841 -- secondary stack is managed by enclosing scopes.
8843 if Manages_Sec_Stack
(Trans_Id
) then
8845 -- Determine whether an enclosing scope already manages the secondary
8848 Scop
:= Scope
(Trans_Id
);
8849 while Present
(Scop
) loop
8851 -- It should not be possible to reach Standard without hitting one
8852 -- of the other cases first unless Standard was manually pushed.
8854 if Scop
= Standard_Standard
then
8857 -- The transient block is within a function which returns on the
8858 -- secondary stack. Take a conservative approach and assume that
8859 -- the value on the secondary stack is part of the result. Note
8860 -- that it is not possible to detect this dependency without flow
8861 -- analysis which the compiler does not have. Letting the object
8862 -- live longer than the transient block will not leak any memory
8863 -- because the caller will reclaim the total storage used by the
8866 elsif Ekind
(Scop
) = E_Function
8867 and then Sec_Stack_Needed_For_Return
(Scop
)
8869 Set_Uses_Sec_Stack
(Trans_Id
, False);
8872 -- The transient block must manage the secondary stack when the
8873 -- block appears within a loop in order to reclaim the memory at
8876 elsif Ekind
(Scop
) = E_Loop
then
8879 -- Ditto when the block appears without a block that does not
8880 -- manage the secondary stack and is located within a loop.
8882 elsif Ekind
(Scop
) = E_Block
8883 and then not Manages_Sec_Stack
(Scop
)
8884 and then Present
(Block_Node
(Scop
))
8885 and then Within_Loop_Statement
(Block_Node
(Scop
))
8889 -- The transient block does not need to manage the secondary stack
8890 -- when there is an enclosing construct which already does that.
8891 -- This optimization saves on SS_Mark and SS_Release calls but may
8892 -- allow objects to live a little longer than required.
8894 -- The transient block must manage the secondary stack when switch
8895 -- -gnatd.s (strict management) is in effect.
8897 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
8898 Set_Uses_Sec_Stack
(Trans_Id
, False);
8901 -- Prevent the search from going too far because transient blocks
8902 -- are bounded by packages and subprogram scopes.
8904 elsif Ekind_In
(Scop
, E_Entry
,
8914 Scop
:= Scope
(Scop
);
8918 -- Create the transient block. Set the parent now since the block itself
8919 -- is not part of the tree. The current scope is the E_Block entity that
8920 -- has been pushed by Establish_Transient_Scope.
8922 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
8925 Make_Block_Statement
(Loc
,
8926 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
8927 Declarations
=> Decls
,
8928 Handled_Statement_Sequence
=>
8929 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8930 Has_Created_Identifier
=> True);
8931 Set_Parent
(Block
, Par
);
8933 -- Insert actions stuck in the transient scopes as well as all freezing
8934 -- nodes needed by those actions. Do not insert cleanup actions here,
8935 -- they will be transferred to the newly created block.
8937 Insert_Actions_In_Scope_Around
8938 (Action
, Clean
=> False, Manage_SS
=> False);
8940 Insert
:= Prev
(Action
);
8942 if Present
(Insert
) then
8943 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
8946 -- Transfer cleanup actions to the newly created block
8949 Cleanup_Actions
: List_Id
8950 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8951 Actions_To_Be_Wrapped
(Cleanup
);
8953 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8954 Cleanup_Actions
:= No_List
;
8957 -- When the transient scope was established, we pushed the entry for the
8958 -- transient scope onto the scope stack, so that the scope was active
8959 -- for the installation of finalizable entities etc. Now we must remove
8960 -- this entry, since we have constructed a proper block.
8965 end Make_Transient_Block
;
8967 ------------------------
8968 -- Node_To_Be_Wrapped --
8969 ------------------------
8971 function Node_To_Be_Wrapped
return Node_Id
is
8973 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8974 end Node_To_Be_Wrapped
;
8976 ----------------------------
8977 -- Set_Node_To_Be_Wrapped --
8978 ----------------------------
8980 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8982 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8983 end Set_Node_To_Be_Wrapped
;
8985 ----------------------------
8986 -- Store_Actions_In_Scope --
8987 ----------------------------
8989 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8990 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8991 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8994 if No
(Actions
) then
8997 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8998 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9000 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9005 elsif AK
= Before
then
9006 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9009 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9011 end Store_Actions_In_Scope
;
9013 ----------------------------------
9014 -- Store_After_Actions_In_Scope --
9015 ----------------------------------
9017 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9019 Store_Actions_In_Scope
(After
, L
);
9020 end Store_After_Actions_In_Scope
;
9022 -----------------------------------
9023 -- Store_Before_Actions_In_Scope --
9024 -----------------------------------
9026 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9028 Store_Actions_In_Scope
(Before
, L
);
9029 end Store_Before_Actions_In_Scope
;
9031 -----------------------------------
9032 -- Store_Cleanup_Actions_In_Scope --
9033 -----------------------------------
9035 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9037 Store_Actions_In_Scope
(Cleanup
, L
);
9038 end Store_Cleanup_Actions_In_Scope
;
9040 --------------------------------
9041 -- Wrap_Transient_Declaration --
9042 --------------------------------
9044 -- If a transient scope has been established during the processing of the
9045 -- Expression of an Object_Declaration, it is not possible to wrap the
9046 -- declaration into a transient block as usual case, otherwise the object
9047 -- would be itself declared in the wrong scope. Therefore, all entities (if
9048 -- any) defined in the transient block are moved to the proper enclosing
9049 -- scope. Furthermore, if they are controlled variables they are finalized
9050 -- right after the declaration. The finalization list of the transient
9051 -- scope is defined as a renaming of the enclosing one so during their
9052 -- initialization they will be attached to the proper finalization list.
9053 -- For instance, the following declaration :
9055 -- X : Typ := F (G (A), G (B));
9057 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9058 -- is expanded into :
9060 -- X : Typ := [ complex Expression-Action ];
9061 -- [Deep_]Finalize (_v1);
9062 -- [Deep_]Finalize (_v2);
9064 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9069 Curr_S
:= Current_Scope
;
9070 Encl_S
:= Scope
(Curr_S
);
9072 -- Insert all actions including cleanup generated while analyzing or
9073 -- expanding the transient context back into the tree. Manage the
9074 -- secondary stack when the object declaration appears in a library
9075 -- level package [body].
9077 Insert_Actions_In_Scope_Around
9081 Uses_Sec_Stack
(Curr_S
)
9082 and then Nkind
(N
) = N_Object_Declaration
9083 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
9084 and then Is_Library_Level_Entity
(Encl_S
));
9087 -- Relocate local entities declared within the transient scope to the
9088 -- enclosing scope. This action sets their Is_Public flag accordingly.
9090 Transfer_Entities
(Curr_S
, Encl_S
);
9092 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9093 -- is properly released upon exiting the said scope.
9095 if Uses_Sec_Stack
(Curr_S
) then
9096 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9098 -- Do not mark a function that returns on the secondary stack as the
9099 -- reclamation is done by the caller.
9101 if Ekind
(Curr_S
) = E_Function
9102 and then Requires_Transient_Scope
(Etype
(Curr_S
))
9106 -- Otherwise mark the enclosing dynamic scope
9109 Set_Uses_Sec_Stack
(Curr_S
);
9110 Check_Restriction
(No_Secondary_Stack
, N
);
9113 end Wrap_Transient_Declaration
;
9115 -------------------------------
9116 -- Wrap_Transient_Expression --
9117 -------------------------------
9119 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9120 Loc
: constant Source_Ptr
:= Sloc
(N
);
9121 Expr
: Node_Id
:= Relocate_Node
(N
);
9122 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9123 Typ
: constant Entity_Id
:= Etype
(N
);
9130 -- M : constant Mark_Id := SS_Mark;
9131 -- procedure Finalizer is ... (See Build_Finalizer)
9134 -- Temp := <Expr>; -- general case
9135 -- Temp := (if <Expr> then True else False); -- boolean case
9141 -- A special case is made for Boolean expressions so that the back end
9142 -- knows to generate a conditional branch instruction, if running with
9143 -- -fpreserve-control-flow. This ensures that a control-flow change
9144 -- signaling the decision outcome occurs before the cleanup actions.
9146 if Opt
.Suppress_Control_Flow_Optimizations
9147 and then Is_Boolean_Type
(Typ
)
9150 Make_If_Expression
(Loc
,
9151 Expressions
=> New_List
(
9153 New_Occurrence_Of
(Standard_True
, Loc
),
9154 New_Occurrence_Of
(Standard_False
, Loc
)));
9157 Insert_Actions
(N
, New_List
(
9158 Make_Object_Declaration
(Loc
,
9159 Defining_Identifier
=> Temp
,
9160 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9162 Make_Transient_Block
(Loc
,
9164 Make_Assignment_Statement
(Loc
,
9165 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9166 Expression
=> Expr
),
9167 Par
=> Parent
(N
))));
9169 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9170 Analyze_And_Resolve
(N
, Typ
);
9171 end Wrap_Transient_Expression
;
9173 ------------------------------
9174 -- Wrap_Transient_Statement --
9175 ------------------------------
9177 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9178 Loc
: constant Source_Ptr
:= Sloc
(N
);
9179 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9184 -- M : constant Mark_Id := SS_Mark;
9185 -- procedure Finalizer is ... (See Build_Finalizer)
9195 Make_Transient_Block
(Loc
,
9197 Par
=> Parent
(N
)));
9199 -- With the scope stack back to normal, we can call analyze on the
9200 -- resulting block. At this point, the transient scope is being
9201 -- treated like a perfectly normal scope, so there is nothing
9202 -- special about it.
9204 -- Note: Wrap_Transient_Statement is called with the node already
9205 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9206 -- otherwise we would get a recursive processing of the node when
9207 -- we do this Analyze call.
9210 end Wrap_Transient_Statement
;