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_Unnesting_In_Declarations
(N
: Node_Id
);
364 -- Similarly, the declarations in the package body may have created
365 -- blocks with nested subprograms. Such a block must be transformed into a
366 -- procedure followed by a call to it, so that unnesting can handle uplevel
367 -- references within these nested subprograms (typically generated
368 -- subprograms to handle finalization actions).
370 procedure Check_Visibly_Controlled
371 (Prim
: Final_Primitives
;
373 E
: in out Entity_Id
;
374 Cref
: in out Node_Id
);
375 -- The controlled operation declared for a derived type may not be
376 -- overriding, if the controlled operations of the parent type are hidden,
377 -- for example when the parent is a private type whose full view is
378 -- controlled. For other primitive operations we modify the name of the
379 -- operation to indicate that it is not overriding, but this is not
380 -- possible for Initialize, etc. because they have to be retrievable by
381 -- name. Before generating the proper call to one of these operations we
382 -- check whether Typ is known to be controlled at the point of definition.
383 -- If it is not then we must retrieve the hidden operation of the parent
384 -- and use it instead. This is one case that might be solved more cleanly
385 -- once Overriding pragmas or declarations are in place.
387 function Convert_View
390 Ind
: Pos
:= 1) return Node_Id
;
391 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
392 -- argument being passed to it. Ind indicates which formal of procedure
393 -- Proc we are trying to match. This function will, if necessary, generate
394 -- a conversion between the partial and full view of Arg to match the type
395 -- of the formal of Proc, or force a conversion to the class-wide type in
396 -- the case where the operation is abstract.
398 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
399 -- Given an arbitrary entity, traverse the scope chain looking for the
400 -- first enclosing function. Return Empty if no function was found.
406 Skip_Self
: Boolean := False) return Node_Id
;
407 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
408 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
409 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
410 -- action has an effect on the components only (if any).
412 function Make_Deep_Proc
413 (Prim
: Final_Primitives
;
415 Stmts
: List_Id
) return Node_Id
;
416 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
417 -- Deep_Finalize procedures according to the first parameter, these
418 -- procedures operate on the type Typ. The Stmts parameter gives the body
421 function Make_Deep_Array_Body
422 (Prim
: Final_Primitives
;
423 Typ
: Entity_Id
) return List_Id
;
424 -- This function generates the list of statements for implementing
425 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
426 -- the first parameter, these procedures operate on the array type Typ.
428 function Make_Deep_Record_Body
429 (Prim
: Final_Primitives
;
431 Is_Local
: Boolean := False) return List_Id
;
432 -- This function generates the list of statements for implementing
433 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
434 -- the first parameter, these procedures operate on the record type Typ.
435 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
436 -- whether the inner logic should be dictated by state counters.
438 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
439 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
440 -- Make_Deep_Record_Body. Generate the following statements:
443 -- type Acc_Typ is access all Typ;
444 -- for Acc_Typ'Storage_Size use 0;
446 -- [Deep_]Finalize (Acc_Typ (V).all);
449 --------------------------------
450 -- Allows_Finalization_Master --
451 --------------------------------
453 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
454 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
455 -- Determine whether entity E is inside a wrapper package created for
456 -- an instance of Ada.Unchecked_Deallocation.
458 ------------------------------
459 -- In_Deallocation_Instance --
460 ------------------------------
462 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
463 Pkg
: constant Entity_Id
:= Scope
(E
);
464 Par
: Node_Id
:= Empty
;
467 if Ekind
(Pkg
) = E_Package
468 and then Present
(Related_Instance
(Pkg
))
469 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
471 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
475 and then Chars
(Par
) = Name_Unchecked_Deallocation
476 and then Chars
(Scope
(Par
)) = Name_Ada
477 and then Scope
(Scope
(Par
)) = Standard_Standard
;
481 end In_Deallocation_Instance
;
485 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
486 Ptr_Typ
: constant Entity_Id
:=
487 Root_Type_Of_Full_View
(Base_Type
(Typ
));
489 -- Start of processing for Allows_Finalization_Master
492 -- Certain run-time configurations and targets do not provide support
493 -- for controlled types and therefore do not need masters.
495 if Restriction_Active
(No_Finalization
) then
498 -- Do not consider C and C++ types since it is assumed that the non-Ada
499 -- side will handle their cleanup.
501 elsif Convention
(Desig_Typ
) = Convention_C
502 or else Convention
(Desig_Typ
) = Convention_CPP
506 -- Do not consider an access type that returns on the secondary stack
508 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
509 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
513 -- Do not consider an access type that can never allocate an object
515 elsif No_Pool_Assigned
(Ptr_Typ
) then
518 -- Do not consider an access type coming from an Unchecked_Deallocation
519 -- instance. Even though the designated type may be controlled, the
520 -- access type will never participate in any allocations.
522 elsif In_Deallocation_Instance
(Ptr_Typ
) then
525 -- Do not consider a non-library access type when No_Nested_Finalization
526 -- is in effect since finalization masters are controlled objects and if
527 -- created will violate the restriction.
529 elsif Restriction_Active
(No_Nested_Finalization
)
530 and then not Is_Library_Level_Entity
(Ptr_Typ
)
534 -- Do not consider an access type subject to pragma No_Heap_Finalization
535 -- because objects allocated through such a type are not to be finalized
536 -- when the access type goes out of scope.
538 elsif No_Heap_Finalization
(Ptr_Typ
) then
541 -- Do not create finalization masters in GNATprove mode because this
542 -- causes unwanted extra expansion. A compilation in this mode must
543 -- keep the tree as close as possible to the original sources.
545 elsif GNATprove_Mode
then
548 -- Otherwise the access type may use a finalization master
553 end Allows_Finalization_Master
;
555 ----------------------------
556 -- Build_Anonymous_Master --
557 ----------------------------
559 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
560 function Create_Anonymous_Master
561 (Desig_Typ
: Entity_Id
;
563 Unit_Decl
: Node_Id
) return Entity_Id
;
564 -- Create a new anonymous master for access type Ptr_Typ with designated
565 -- type Desig_Typ. The declaration of the master and its initialization
566 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
567 -- the entity of Unit_Decl.
569 function Current_Anonymous_Master
570 (Desig_Typ
: Entity_Id
;
571 Unit_Id
: Entity_Id
) return Entity_Id
;
572 -- Find an anonymous master declared within unit Unit_Id which services
573 -- designated type Desig_Typ. If there is no such master, return Empty.
575 -----------------------------
576 -- Create_Anonymous_Master --
577 -----------------------------
579 function Create_Anonymous_Master
580 (Desig_Typ
: Entity_Id
;
582 Unit_Decl
: Node_Id
) return Entity_Id
584 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
595 -- <FM_Id> : Finalization_Master;
597 FM_Id
:= Make_Temporary
(Loc
, 'A');
600 Make_Object_Declaration
(Loc
,
601 Defining_Identifier
=> FM_Id
,
603 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
607 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
610 Make_Procedure_Call_Statement
(Loc
,
612 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
613 Parameter_Associations
=> New_List
(
614 New_Occurrence_Of
(FM_Id
, Loc
),
615 Make_Attribute_Reference
(Loc
,
617 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
618 Attribute_Name
=> Name_Unrestricted_Access
)));
620 -- Find the declarative list of the unit
622 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
623 Unit_Spec
:= Specification
(Unit_Decl
);
624 Decls
:= Visible_Declarations
(Unit_Spec
);
628 Set_Visible_Declarations
(Unit_Spec
, Decls
);
631 -- Package body or subprogram case
633 -- ??? A subprogram spec or body that acts as a compilation unit may
634 -- contain a formal parameter of an anonymous access-to-controlled
635 -- type initialized by an allocator.
637 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
639 -- There is no suitable place to create the master as the subprogram
640 -- is not in a declarative list.
643 Decls
:= Declarations
(Unit_Decl
);
647 Set_Declarations
(Unit_Decl
, Decls
);
651 Prepend_To
(Decls
, FM_Init
);
652 Prepend_To
(Decls
, FM_Decl
);
654 -- Use the scope of the unit when analyzing the declaration of the
655 -- master and its initialization actions.
657 Push_Scope
(Unit_Id
);
662 -- Mark the master as servicing this specific designated type
664 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
666 -- Include the anonymous master in the list of existing masters which
667 -- appear in this unit. This effectively creates a mapping between a
668 -- master and a designated type which in turn allows for the reuse of
669 -- masters on a per-unit basis.
671 All_FMs
:= Anonymous_Masters
(Unit_Id
);
674 All_FMs
:= New_Elmt_List
;
675 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
678 Prepend_Elmt
(FM_Id
, All_FMs
);
681 end Create_Anonymous_Master
;
683 ------------------------------
684 -- Current_Anonymous_Master --
685 ------------------------------
687 function Current_Anonymous_Master
688 (Desig_Typ
: Entity_Id
;
689 Unit_Id
: Entity_Id
) return Entity_Id
691 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
696 -- Inspect the list of anonymous masters declared within the unit
697 -- looking for an existing master which services the same designated
700 if Present
(All_FMs
) then
701 FM_Elmt
:= First_Elmt
(All_FMs
);
702 while Present
(FM_Elmt
) loop
703 FM_Id
:= Node
(FM_Elmt
);
705 -- The currect master services the same designated type. As a
706 -- result the master can be reused and associated with another
707 -- anonymous access-to-controlled type.
709 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
718 end Current_Anonymous_Master
;
722 Desig_Typ
: Entity_Id
;
724 Priv_View
: Entity_Id
;
728 -- Start of processing for Build_Anonymous_Master
731 -- Nothing to do if the circumstances do not allow for a finalization
734 if not Allows_Finalization_Master
(Ptr_Typ
) then
738 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
739 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
741 -- The compilation unit is a package instantiation. In this case the
742 -- anonymous master is associated with the package spec as both the
743 -- spec and body appear at the same level.
745 if Nkind
(Unit_Decl
) = N_Package_Body
746 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
748 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
749 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
752 -- Use the initial declaration of the designated type when it denotes
753 -- the full view of an incomplete or private type. This ensures that
754 -- types with one and two views are treated the same.
756 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
757 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
759 if Present
(Priv_View
) then
760 Desig_Typ
:= Priv_View
;
763 -- Determine whether the current semantic unit already has an anonymous
764 -- master which services the designated type.
766 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
768 -- If this is not the case, create a new master
771 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
774 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
775 end Build_Anonymous_Master
;
777 ----------------------------
778 -- Build_Array_Deep_Procs --
779 ----------------------------
781 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
785 (Prim
=> Initialize_Case
,
787 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
789 if not Is_Limited_View
(Typ
) then
792 (Prim
=> Adjust_Case
,
794 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
797 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
798 -- suppressed since these routine will not be used.
800 if not Restriction_Active
(No_Finalization
) then
803 (Prim
=> Finalize_Case
,
805 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
807 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
809 if not CodePeer_Mode
then
812 (Prim
=> Address_Case
,
814 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
817 end Build_Array_Deep_Procs
;
819 ------------------------------
820 -- Build_Cleanup_Statements --
821 ------------------------------
823 function Build_Cleanup_Statements
825 Additional_Cleanup
: List_Id
) return List_Id
827 Is_Asynchronous_Call
: constant Boolean :=
828 Nkind
(N
) = N_Block_Statement
829 and then Is_Asynchronous_Call_Block
(N
);
830 Is_Master
: constant Boolean :=
831 Nkind
(N
) /= N_Entry_Body
832 and then Is_Task_Master
(N
);
833 Is_Protected_Body
: constant Boolean :=
834 Nkind
(N
) = N_Subprogram_Body
835 and then Is_Protected_Subprogram_Body
(N
);
836 Is_Task_Allocation
: constant Boolean :=
837 Nkind
(N
) = N_Block_Statement
838 and then Is_Task_Allocation_Block
(N
);
839 Is_Task_Body
: constant Boolean :=
840 Nkind
(Original_Node
(N
)) = N_Task_Body
;
842 Loc
: constant Source_Ptr
:= Sloc
(N
);
843 Stmts
: constant List_Id
:= New_List
;
847 if Restricted_Profile
then
849 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
851 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
855 if Restriction_Active
(No_Task_Hierarchy
) = False then
856 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
859 -- Add statements to unlock the protected object parameter and to
860 -- undefer abort. If the context is a protected procedure and the object
861 -- has entries, call the entry service routine.
863 -- NOTE: The generated code references _object, a parameter to the
866 elsif Is_Protected_Body
then
868 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
869 Conc_Typ
: Entity_Id
;
871 Param_Typ
: Entity_Id
;
874 -- Find the _object parameter representing the protected object
876 Param
:= First
(Parameter_Specifications
(Spec
));
878 Param_Typ
:= Etype
(Parameter_Type
(Param
));
880 if Ekind
(Param_Typ
) = E_Record_Type
then
881 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
884 exit when No
(Param
) or else Present
(Conc_Typ
);
888 pragma Assert
(Present
(Param
));
890 -- Historical note: In earlier versions of GNAT, there was code
891 -- at this point to generate stuff to service entry queues. It is
892 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
894 Build_Protected_Subprogram_Call_Cleanup
895 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
898 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
899 -- tasks. Other unactivated tasks are completed by Complete_Task or
902 -- NOTE: The generated code references _chain, a local object
904 elsif Is_Task_Allocation
then
907 -- Expunge_Unactivated_Tasks (_chain);
909 -- where _chain is the list of tasks created by the allocator but not
910 -- yet activated. This list will be empty unless the block completes
914 Make_Procedure_Call_Statement
(Loc
,
917 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
918 Parameter_Associations
=> New_List
(
919 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
921 -- Attempt to cancel an asynchronous entry call whenever the block which
922 -- contains the abortable part is exited.
924 -- NOTE: The generated code references Cnn, a local object
926 elsif Is_Asynchronous_Call
then
928 Cancel_Param
: constant Entity_Id
:=
929 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
932 -- If it is of type Communication_Block, this must be a protected
933 -- entry call. Generate:
935 -- if Enqueued (Cancel_Param) then
936 -- Cancel_Protected_Entry_Call (Cancel_Param);
939 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
941 Make_If_Statement
(Loc
,
943 Make_Function_Call
(Loc
,
945 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
946 Parameter_Associations
=> New_List
(
947 New_Occurrence_Of
(Cancel_Param
, Loc
))),
949 Then_Statements
=> New_List
(
950 Make_Procedure_Call_Statement
(Loc
,
953 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
954 Parameter_Associations
=> New_List
(
955 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
957 -- Asynchronous delay, generate:
958 -- Cancel_Async_Delay (Cancel_Param);
960 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
962 Make_Procedure_Call_Statement
(Loc
,
964 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
965 Parameter_Associations
=> New_List
(
966 Make_Attribute_Reference
(Loc
,
968 New_Occurrence_Of
(Cancel_Param
, Loc
),
969 Attribute_Name
=> Name_Unchecked_Access
))));
971 -- Task entry call, generate:
972 -- Cancel_Task_Entry_Call (Cancel_Param);
976 Make_Procedure_Call_Statement
(Loc
,
978 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
979 Parameter_Associations
=> New_List
(
980 New_Occurrence_Of
(Cancel_Param
, Loc
))));
985 Append_List_To
(Stmts
, Additional_Cleanup
);
987 end Build_Cleanup_Statements
;
989 -----------------------------
990 -- Build_Controlling_Procs --
991 -----------------------------
993 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
995 if Is_Array_Type
(Typ
) then
996 Build_Array_Deep_Procs
(Typ
);
997 else pragma Assert
(Is_Record_Type
(Typ
));
998 Build_Record_Deep_Procs
(Typ
);
1000 end Build_Controlling_Procs
;
1002 -----------------------------
1003 -- Build_Exception_Handler --
1004 -----------------------------
1006 function Build_Exception_Handler
1007 (Data
: Finalization_Exception_Data
;
1008 For_Library
: Boolean := False) return Node_Id
1011 Proc_To_Call
: Entity_Id
;
1016 pragma Assert
(Present
(Data
.Raised_Id
));
1018 if Exception_Extra_Info
1019 or else (For_Library
and not Restricted_Profile
)
1021 if Exception_Extra_Info
then
1025 -- Get_Current_Excep.all
1028 Make_Function_Call
(Data
.Loc
,
1030 Make_Explicit_Dereference
(Data
.Loc
,
1033 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1040 Except
:= Make_Null
(Data
.Loc
);
1043 if For_Library
and then not Restricted_Profile
then
1044 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1045 Actuals
:= New_List
(Except
);
1048 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1050 -- The dereference occurs only when Exception_Extra_Info is true,
1051 -- and therefore Except is not null.
1055 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1056 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1062 -- if not Raised_Id then
1063 -- Raised_Id := True;
1065 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1067 -- Save_Library_Occurrence (Get_Current_Excep.all);
1072 Make_If_Statement
(Data
.Loc
,
1074 Make_Op_Not
(Data
.Loc
,
1075 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1077 Then_Statements
=> New_List
(
1078 Make_Assignment_Statement
(Data
.Loc
,
1079 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1080 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1082 Make_Procedure_Call_Statement
(Data
.Loc
,
1084 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1085 Parameter_Associations
=> Actuals
))));
1090 -- Raised_Id := True;
1093 Make_Assignment_Statement
(Data
.Loc
,
1094 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1095 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1103 Make_Exception_Handler
(Data
.Loc
,
1104 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1105 Statements
=> Stmts
);
1106 end Build_Exception_Handler
;
1108 -------------------------------
1109 -- Build_Finalization_Master --
1110 -------------------------------
1112 procedure Build_Finalization_Master
1114 For_Lib_Level
: Boolean := False;
1115 For_Private
: Boolean := False;
1116 Context_Scope
: Entity_Id
:= Empty
;
1117 Insertion_Node
: Node_Id
:= Empty
)
1119 procedure Add_Pending_Access_Type
1121 Ptr_Typ
: Entity_Id
);
1122 -- Add access type Ptr_Typ to the pending access type list for type Typ
1124 -----------------------------
1125 -- Add_Pending_Access_Type --
1126 -----------------------------
1128 procedure Add_Pending_Access_Type
1130 Ptr_Typ
: Entity_Id
)
1135 if Present
(Pending_Access_Types
(Typ
)) then
1136 List
:= Pending_Access_Types
(Typ
);
1138 List
:= New_Elmt_List
;
1139 Set_Pending_Access_Types
(Typ
, List
);
1142 Prepend_Elmt
(Ptr_Typ
, List
);
1143 end Add_Pending_Access_Type
;
1147 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1149 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1150 -- A finalization master created for a named access type is associated
1151 -- with the full view (if applicable) as a consequence of freezing. The
1152 -- full view criteria does not apply to anonymous access types because
1153 -- those cannot have a private and a full view.
1155 -- Start of processing for Build_Finalization_Master
1158 -- Nothing to do if the circumstances do not allow for a finalization
1161 if not Allows_Finalization_Master
(Typ
) then
1164 -- Various machinery such as freezing may have already created a
1165 -- finalization master.
1167 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1172 Actions
: constant List_Id
:= New_List
;
1173 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1174 Fin_Mas_Id
: Entity_Id
;
1175 Pool_Id
: Entity_Id
;
1178 -- Source access types use fixed master names since the master is
1179 -- inserted in the same source unit only once. The only exception to
1180 -- this are instances using the same access type as generic actual.
1182 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1184 Make_Defining_Identifier
(Loc
,
1185 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1187 -- Internally generated access types use temporaries as their names
1188 -- due to possible collision with identical names coming from other
1192 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1195 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1198 -- <Ptr_Typ>FM : aliased Finalization_Master;
1201 Make_Object_Declaration
(Loc
,
1202 Defining_Identifier
=> Fin_Mas_Id
,
1203 Aliased_Present
=> True,
1204 Object_Definition
=>
1205 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1207 -- Set the associated pool and primitive Finalize_Address of the new
1208 -- finalization master.
1210 -- The access type has a user-defined storage pool, use it
1212 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1213 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1215 -- Otherwise the default choice is the global storage pool
1218 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1219 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1223 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1226 Make_Procedure_Call_Statement
(Loc
,
1228 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1229 Parameter_Associations
=> New_List
(
1230 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1231 Make_Attribute_Reference
(Loc
,
1232 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1233 Attribute_Name
=> Name_Unrestricted_Access
))));
1235 -- Finalize_Address is not generated in CodePeer mode because the
1236 -- body contains address arithmetic. Skip this step.
1238 if CodePeer_Mode
then
1241 -- Associate the Finalize_Address primitive of the designated type
1242 -- with the finalization master of the access type. The designated
1243 -- type must be forzen as Finalize_Address is generated when the
1244 -- freeze node is expanded.
1246 elsif Is_Frozen
(Desig_Typ
)
1247 and then Present
(Finalize_Address
(Desig_Typ
))
1249 -- The finalization master of an anonymous access type may need
1250 -- to be inserted in a specific place in the tree. For instance:
1254 -- <finalization master of "access Comp_Typ">
1256 -- type Rec_Typ is record
1257 -- Comp : access Comp_Typ;
1260 -- <freeze node for Comp_Typ>
1261 -- <freeze node for Rec_Typ>
1263 -- Due to this oddity, the anonymous access type is stored for
1264 -- later processing (see below).
1266 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1269 -- Set_Finalize_Address
1270 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1273 Make_Set_Finalize_Address_Call
1275 Ptr_Typ
=> Ptr_Typ
));
1277 -- Otherwise the designated type is either anonymous access or a
1278 -- Taft-amendment type and has not been frozen. Store the access
1279 -- type for later processing (see Freeze_Type).
1282 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1285 -- A finalization master created for an access designating a type
1286 -- with private components is inserted before a context-dependent
1291 -- At this point both the scope of the context and the insertion
1292 -- mode must be known.
1294 pragma Assert
(Present
(Context_Scope
));
1295 pragma Assert
(Present
(Insertion_Node
));
1297 Push_Scope
(Context_Scope
);
1299 -- Treat use clauses as declarations and insert directly in front
1302 if Nkind_In
(Insertion_Node
, N_Use_Package_Clause
,
1305 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1307 Insert_Actions
(Insertion_Node
, Actions
);
1312 -- The finalization master belongs to an access result type related
1313 -- to a build-in-place function call used to initialize a library
1314 -- level object. The master must be inserted in front of the access
1315 -- result type declaration denoted by Insertion_Node.
1317 elsif For_Lib_Level
then
1318 pragma Assert
(Present
(Insertion_Node
));
1319 Insert_Actions
(Insertion_Node
, Actions
);
1321 -- Otherwise the finalization master and its initialization become a
1322 -- part of the freeze node.
1325 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1328 end Build_Finalization_Master
;
1330 ---------------------
1331 -- Build_Finalizer --
1332 ---------------------
1334 procedure Build_Finalizer
1336 Clean_Stmts
: List_Id
;
1337 Mark_Id
: Entity_Id
;
1338 Top_Decls
: List_Id
;
1339 Defer_Abort
: Boolean;
1340 Fin_Id
: out Entity_Id
)
1342 Acts_As_Clean
: constant Boolean :=
1345 (Present
(Clean_Stmts
)
1346 and then Is_Non_Empty_List
(Clean_Stmts
));
1348 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1349 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1350 For_Package
: constant Boolean :=
1351 For_Package_Body
or else For_Package_Spec
;
1352 Loc
: constant Source_Ptr
:= Sloc
(N
);
1354 -- NOTE: Local variable declarations are conservative and do not create
1355 -- structures right from the start. Entities and lists are created once
1356 -- it has been established that N has at least one controlled object.
1358 Components_Built
: Boolean := False;
1359 -- A flag used to avoid double initialization of entities and lists. If
1360 -- the flag is set then the following variables have been initialized:
1366 Counter_Id
: Entity_Id
:= Empty
;
1367 Counter_Val
: Nat
:= 0;
1368 -- Name and value of the state counter
1370 Decls
: List_Id
:= No_List
;
1371 -- Declarative region of N (if available). If N is a package declaration
1372 -- Decls denotes the visible declarations.
1374 Finalizer_Data
: Finalization_Exception_Data
;
1375 -- Data for the exception
1377 Finalizer_Decls
: List_Id
:= No_List
;
1378 -- Local variable declarations. This list holds the label declarations
1379 -- of all jump block alternatives as well as the declaration of the
1380 -- local exception occurrence and the raised flag:
1381 -- E : Exception_Occurrence;
1382 -- Raised : Boolean := False;
1383 -- L<counter value> : label;
1385 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1386 -- Insertion point for the finalizer body. Depending on the context
1387 -- (Nkind of N) and the individual grouping of controlled objects, this
1388 -- node may denote a package declaration or body, package instantiation,
1389 -- block statement or a counter update statement.
1391 Finalizer_Stmts
: List_Id
:= No_List
;
1392 -- The statement list of the finalizer body. It contains the following:
1394 -- Abort_Defer; -- Added if abort is allowed
1395 -- <call to Prev_At_End> -- Added if exists
1396 -- <cleanup statements> -- Added if Acts_As_Clean
1397 -- <jump block> -- Added if Has_Ctrl_Objs
1398 -- <finalization statements> -- Added if Has_Ctrl_Objs
1399 -- <stack release> -- Added if Mark_Id exists
1400 -- Abort_Undefer; -- Added if abort is allowed
1402 Has_Ctrl_Objs
: Boolean := False;
1403 -- A general flag which denotes whether N has at least one controlled
1406 Has_Tagged_Types
: Boolean := False;
1407 -- A general flag which indicates whether N has at least one library-
1408 -- level tagged type declaration.
1410 HSS
: Node_Id
:= Empty
;
1411 -- The sequence of statements of N (if available)
1413 Jump_Alts
: List_Id
:= No_List
;
1414 -- Jump block alternatives. Depending on the value of the state counter,
1415 -- the control flow jumps to a sequence of finalization statements. This
1416 -- list contains the following:
1418 -- when <counter value> =>
1419 -- goto L<counter value>;
1421 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1422 -- Specific point in the finalizer statements where the jump block is
1425 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1426 -- The last controlled construct encountered when processing the top
1427 -- level lists of N. This can be a nested package, an instantiation or
1428 -- an object declaration.
1430 Prev_At_End
: Entity_Id
:= Empty
;
1431 -- The previous at end procedure of the handled statements block of N
1433 Priv_Decls
: List_Id
:= No_List
;
1434 -- The private declarations of N if N is a package declaration
1436 Spec_Id
: Entity_Id
:= Empty
;
1437 Spec_Decls
: List_Id
:= Top_Decls
;
1438 Stmts
: List_Id
:= No_List
;
1440 Tagged_Type_Stmts
: List_Id
:= No_List
;
1441 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1442 -- tagged types found in N.
1444 -----------------------
1445 -- Local subprograms --
1446 -----------------------
1448 procedure Build_Components
;
1449 -- Create all entites and initialize all lists used in the creation of
1452 procedure Create_Finalizer
;
1453 -- Create the spec and body of the finalizer and insert them in the
1454 -- proper place in the tree depending on the context.
1456 procedure Process_Declarations
1458 Preprocess
: Boolean := False;
1459 Top_Level
: Boolean := False);
1460 -- Inspect a list of declarations or statements which may contain
1461 -- objects that need finalization. When flag Preprocess is set, the
1462 -- routine will simply count the total number of controlled objects in
1463 -- Decls. Flag Top_Level denotes whether the processing is done for
1464 -- objects in nested package declarations or instances.
1466 procedure Process_Object_Declaration
1468 Has_No_Init
: Boolean := False;
1469 Is_Protected
: Boolean := False);
1470 -- Generate all the machinery associated with the finalization of a
1471 -- single object. Flag Has_No_Init is used to denote certain contexts
1472 -- where Decl does not have initialization call(s). Flag Is_Protected
1473 -- is set when Decl denotes a simple protected object.
1475 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1476 -- Generate all the code necessary to unregister the external tag of a
1479 ----------------------
1480 -- Build_Components --
1481 ----------------------
1483 procedure Build_Components
is
1484 Counter_Decl
: Node_Id
;
1485 Counter_Typ
: Entity_Id
;
1486 Counter_Typ_Decl
: Node_Id
;
1489 pragma Assert
(Present
(Decls
));
1491 -- This routine might be invoked several times when dealing with
1492 -- constructs that have two lists (either two declarative regions
1493 -- or declarations and statements). Avoid double initialization.
1495 if Components_Built
then
1499 Components_Built
:= True;
1501 if Has_Ctrl_Objs
then
1503 -- Create entities for the counter, its type, the local exception
1504 -- and the raised flag.
1506 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1507 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1509 Finalizer_Decls
:= New_List
;
1511 Build_Object_Declarations
1512 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1514 -- Since the total number of controlled objects is always known,
1515 -- build a subtype of Natural with precise bounds. This allows
1516 -- the backend to optimize the case statement. Generate:
1518 -- subtype Tnn is Natural range 0 .. Counter_Val;
1521 Make_Subtype_Declaration
(Loc
,
1522 Defining_Identifier
=> Counter_Typ
,
1523 Subtype_Indication
=>
1524 Make_Subtype_Indication
(Loc
,
1525 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1527 Make_Range_Constraint
(Loc
,
1531 Make_Integer_Literal
(Loc
, Uint_0
),
1533 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1535 -- Generate the declaration of the counter itself:
1537 -- Counter : Integer := 0;
1540 Make_Object_Declaration
(Loc
,
1541 Defining_Identifier
=> Counter_Id
,
1542 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1543 Expression
=> Make_Integer_Literal
(Loc
, 0));
1545 -- Set the type of the counter explicitly to prevent errors when
1546 -- examining object declarations later on.
1548 Set_Etype
(Counter_Id
, Counter_Typ
);
1550 -- The counter and its type are inserted before the source
1551 -- declarations of N.
1553 Prepend_To
(Decls
, Counter_Decl
);
1554 Prepend_To
(Decls
, Counter_Typ_Decl
);
1556 -- The counter and its associated type must be manually analyzed
1557 -- since N has already been analyzed. Use the scope of the spec
1558 -- when inserting in a package.
1561 Push_Scope
(Spec_Id
);
1562 Analyze
(Counter_Typ_Decl
);
1563 Analyze
(Counter_Decl
);
1567 Analyze
(Counter_Typ_Decl
);
1568 Analyze
(Counter_Decl
);
1571 Jump_Alts
:= New_List
;
1574 -- If the context requires additional cleanup, the finalization
1575 -- machinery is added after the cleanup code.
1577 if Acts_As_Clean
then
1578 Finalizer_Stmts
:= Clean_Stmts
;
1579 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1581 Finalizer_Stmts
:= New_List
;
1584 if Has_Tagged_Types
then
1585 Tagged_Type_Stmts
:= New_List
;
1587 end Build_Components
;
1589 ----------------------
1590 -- Create_Finalizer --
1591 ----------------------
1593 procedure Create_Finalizer
is
1594 function New_Finalizer_Name
return Name_Id
;
1595 -- Create a fully qualified name of a package spec or body finalizer.
1596 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1598 ------------------------
1599 -- New_Finalizer_Name --
1600 ------------------------
1602 function New_Finalizer_Name
return Name_Id
is
1603 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1604 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1605 -- has a non-standard scope, process the scope first.
1607 ------------------------
1608 -- New_Finalizer_Name --
1609 ------------------------
1611 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1613 if Scope
(Id
) = Standard_Standard
then
1614 Get_Name_String
(Chars
(Id
));
1617 New_Finalizer_Name
(Scope
(Id
));
1618 Add_Str_To_Name_Buffer
("__");
1619 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1621 end New_Finalizer_Name
;
1623 -- Start of processing for New_Finalizer_Name
1626 -- Create the fully qualified name of the enclosing scope
1628 New_Finalizer_Name
(Spec_Id
);
1631 -- __finalize_[spec|body]
1633 Add_Str_To_Name_Buffer
("__finalize_");
1635 if For_Package_Spec
then
1636 Add_Str_To_Name_Buffer
("spec");
1638 Add_Str_To_Name_Buffer
("body");
1642 end New_Finalizer_Name
;
1646 Body_Id
: Entity_Id
;
1649 Jump_Block
: Node_Id
;
1651 Label_Id
: Entity_Id
;
1653 -- Start of processing for Create_Finalizer
1656 -- Step 1: Creation of the finalizer name
1658 -- Packages must use a distinct name for their finalizers since the
1659 -- binder will have to generate calls to them by name. The name is
1660 -- of the following form:
1662 -- xx__yy__finalize_[spec|body]
1665 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1666 Set_Has_Qualified_Name
(Fin_Id
);
1667 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1669 -- The default name is _finalizer
1673 Make_Defining_Identifier
(Loc
,
1674 Chars
=> New_External_Name
(Name_uFinalizer
));
1676 -- The visibility semantics of AT_END handlers force a strange
1677 -- separation of spec and body for stack-related finalizers:
1679 -- declare : Enclosing_Scope
1680 -- procedure _finalizer;
1682 -- <controlled objects>
1683 -- procedure _finalizer is
1689 -- Both spec and body are within the same construct and scope, but
1690 -- the body is part of the handled sequence of statements. This
1691 -- placement confuses the elaboration mechanism on targets where
1692 -- AT_END handlers are expanded into "when all others" handlers:
1695 -- when all others =>
1696 -- _finalizer; -- appears to require elab checks
1701 -- Since the compiler guarantees that the body of a _finalizer is
1702 -- always inserted in the same construct where the AT_END handler
1703 -- resides, there is no need for elaboration checks.
1705 Set_Kill_Elaboration_Checks
(Fin_Id
);
1707 -- Inlining the finalizer produces a substantial speedup at -O2.
1708 -- It is inlined by default at -O3. Either way, it is called
1709 -- exactly twice (once on the normal path, and once for
1710 -- exceptions/abort), so this won't bloat the code too much.
1712 Set_Is_Inlined
(Fin_Id
);
1715 -- Step 2: Creation of the finalizer specification
1718 -- procedure Fin_Id;
1721 Make_Subprogram_Declaration
(Loc
,
1723 Make_Procedure_Specification
(Loc
,
1724 Defining_Unit_Name
=> Fin_Id
));
1726 -- Step 3: Creation of the finalizer body
1728 if Has_Ctrl_Objs
then
1730 -- Add L0, the default destination to the jump block
1732 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1733 Set_Entity
(Label_Id
,
1734 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1735 Label
:= Make_Label
(Loc
, Label_Id
);
1740 Prepend_To
(Finalizer_Decls
,
1741 Make_Implicit_Label_Declaration
(Loc
,
1742 Defining_Identifier
=> Entity
(Label_Id
),
1743 Label_Construct
=> Label
));
1749 Append_To
(Jump_Alts
,
1750 Make_Case_Statement_Alternative
(Loc
,
1751 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1752 Statements
=> New_List
(
1753 Make_Goto_Statement
(Loc
,
1754 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1759 Append_To
(Finalizer_Stmts
, Label
);
1761 -- Create the jump block which controls the finalization flow
1762 -- depending on the value of the state counter.
1765 Make_Case_Statement
(Loc
,
1766 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1767 Alternatives
=> Jump_Alts
);
1769 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1770 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1772 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1776 -- Add the library-level tagged type unregistration machinery before
1777 -- the jump block circuitry. This ensures that external tags will be
1778 -- removed even if a finalization exception occurs at some point.
1780 if Has_Tagged_Types
then
1781 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1784 -- Add a call to the previous At_End handler if it exists. The call
1785 -- must always precede the jump block.
1787 if Present
(Prev_At_End
) then
1788 Prepend_To
(Finalizer_Stmts
,
1789 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1791 -- Clear the At_End handler since we have already generated the
1792 -- proper replacement call for it.
1794 Set_At_End_Proc
(HSS
, Empty
);
1797 -- Release the secondary stack
1799 if Present
(Mark_Id
) then
1801 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1804 -- If the context is a build-in-place function, the secondary
1805 -- stack must be released, unless the build-in-place function
1806 -- itself is returning on the secondary stack. Generate:
1808 -- if BIP_Alloc_Form /= Secondary_Stack then
1809 -- SS_Release (Mark_Id);
1812 -- Note that if the function returns on the secondary stack,
1813 -- then the responsibility of reclaiming the space is always
1814 -- left to the caller (recursively if needed).
1816 if Nkind
(N
) = N_Subprogram_Body
then
1818 Spec_Id
: constant Entity_Id
:=
1819 Unique_Defining_Entity
(N
);
1820 BIP_SS
: constant Boolean :=
1821 Is_Build_In_Place_Function
(Spec_Id
)
1822 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1826 Make_If_Statement
(Loc
,
1831 (Build_In_Place_Formal
1832 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1834 Make_Integer_Literal
(Loc
,
1836 (BIP_Allocation_Form
'Pos
1837 (Secondary_Stack
)))),
1839 Then_Statements
=> New_List
(Release
));
1844 Append_To
(Finalizer_Stmts
, Release
);
1848 -- Protect the statements with abort defer/undefer. This is only when
1849 -- aborts are allowed and the cleanup statements require deferral or
1850 -- there are controlled objects to be finalized. Note that the abort
1851 -- defer/undefer pair does not require an extra block because each
1852 -- finalization exception is caught in its corresponding finalization
1853 -- block. As a result, the call to Abort_Defer always takes place.
1855 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1856 Prepend_To
(Finalizer_Stmts
,
1857 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1859 Append_To
(Finalizer_Stmts
,
1860 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1863 -- The local exception does not need to be reraised for library-level
1864 -- finalizers. Note that this action must be carried out after object
1865 -- cleanup, secondary stack release, and abort undeferral. Generate:
1867 -- if Raised and then not Abort then
1868 -- Raise_From_Controlled_Operation (E);
1871 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1872 Append_To
(Finalizer_Stmts
,
1873 Build_Raise_Statement
(Finalizer_Data
));
1877 -- procedure Fin_Id is
1878 -- Abort : constant Boolean := Triggered_By_Abort;
1880 -- Abort : constant Boolean := False; -- no abort
1882 -- E : Exception_Occurrence; -- All added if flag
1883 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1889 -- Abort_Defer; -- Added if abort is allowed
1890 -- <call to Prev_At_End> -- Added if exists
1891 -- <cleanup statements> -- Added if Acts_As_Clean
1892 -- <jump block> -- Added if Has_Ctrl_Objs
1893 -- <finalization statements> -- Added if Has_Ctrl_Objs
1894 -- <stack release> -- Added if Mark_Id exists
1895 -- Abort_Undefer; -- Added if abort is allowed
1896 -- <exception propagation> -- Added if Has_Ctrl_Objs
1899 -- Create the body of the finalizer
1901 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1904 Set_Has_Qualified_Name
(Body_Id
);
1905 Set_Has_Fully_Qualified_Name
(Body_Id
);
1909 Make_Subprogram_Body
(Loc
,
1911 Make_Procedure_Specification
(Loc
,
1912 Defining_Unit_Name
=> Body_Id
),
1913 Declarations
=> Finalizer_Decls
,
1914 Handled_Statement_Sequence
=>
1915 Make_Handled_Sequence_Of_Statements
(Loc
,
1916 Statements
=> Finalizer_Stmts
));
1918 -- Step 4: Spec and body insertion, analysis
1922 -- If the package spec has private declarations, the finalizer
1923 -- body must be added to the end of the list in order to have
1924 -- visibility of all private controlled objects.
1926 if For_Package_Spec
then
1927 if Present
(Priv_Decls
) then
1928 Append_To
(Priv_Decls
, Fin_Spec
);
1929 Append_To
(Priv_Decls
, Fin_Body
);
1931 Append_To
(Decls
, Fin_Spec
);
1932 Append_To
(Decls
, Fin_Body
);
1935 -- For package bodies, both the finalizer spec and body are
1936 -- inserted at the end of the package declarations.
1939 Append_To
(Decls
, Fin_Spec
);
1940 Append_To
(Decls
, Fin_Body
);
1943 -- Push the name of the package
1945 Push_Scope
(Spec_Id
);
1953 -- Create the spec for the finalizer. The At_End handler must be
1954 -- able to call the body which resides in a nested structure.
1958 -- procedure Fin_Id; -- Spec
1960 -- <objects and possibly statements>
1961 -- procedure Fin_Id is ... -- Body
1964 -- Fin_Id; -- At_End handler
1967 pragma Assert
(Present
(Spec_Decls
));
1969 Append_To
(Spec_Decls
, Fin_Spec
);
1972 -- When the finalizer acts solely as a cleanup routine, the body
1973 -- is inserted right after the spec.
1975 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1976 Insert_After
(Fin_Spec
, Fin_Body
);
1978 -- In all other cases the body is inserted after either:
1980 -- 1) The counter update statement of the last controlled object
1981 -- 2) The last top level nested controlled package
1982 -- 3) The last top level controlled instantiation
1985 -- Manually freeze the spec. This is somewhat of a hack because
1986 -- a subprogram is frozen when its body is seen and the freeze
1987 -- node appears right before the body. However, in this case,
1988 -- the spec must be frozen earlier since the At_End handler
1989 -- must be able to call it.
1992 -- procedure Fin_Id; -- Spec
1993 -- [Fin_Id] -- Freeze node
1997 -- Fin_Id; -- At_End handler
2000 Ensure_Freeze_Node
(Fin_Id
);
2001 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2002 Set_Is_Frozen
(Fin_Id
);
2004 -- In the case where the last construct to contain a controlled
2005 -- object is either a nested package, an instantiation or a
2006 -- freeze node, the body must be inserted directly after the
2009 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
2011 N_Package_Declaration
,
2014 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2017 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2020 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2022 end Create_Finalizer
;
2024 --------------------------
2025 -- Process_Declarations --
2026 --------------------------
2028 procedure Process_Declarations
2030 Preprocess
: Boolean := False;
2031 Top_Level
: Boolean := False)
2036 Obj_Typ
: Entity_Id
;
2037 Pack_Id
: Entity_Id
;
2041 Old_Counter_Val
: Nat
;
2042 -- This variable is used to determine whether a nested package or
2043 -- instance contains at least one controlled object.
2045 procedure Processing_Actions
2046 (Has_No_Init
: Boolean := False;
2047 Is_Protected
: Boolean := False);
2048 -- Depending on the mode of operation of Process_Declarations, either
2049 -- increment the controlled object counter, set the controlled object
2050 -- flag and store the last top level construct or process the current
2051 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2052 -- the current declaration may not have initialization proc(s). Flag
2053 -- Is_Protected should be set when the current declaration denotes a
2054 -- simple protected object.
2056 ------------------------
2057 -- Processing_Actions --
2058 ------------------------
2060 procedure Processing_Actions
2061 (Has_No_Init
: Boolean := False;
2062 Is_Protected
: Boolean := False)
2065 -- Library-level tagged type
2067 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2069 Has_Tagged_Types
:= True;
2071 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2072 Last_Top_Level_Ctrl_Construct
:= Decl
;
2076 Process_Tagged_Type_Declaration
(Decl
);
2079 -- Controlled object declaration
2083 Counter_Val
:= Counter_Val
+ 1;
2084 Has_Ctrl_Objs
:= True;
2086 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2087 Last_Top_Level_Ctrl_Construct
:= Decl
;
2091 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2094 end Processing_Actions
;
2096 -- Start of processing for Process_Declarations
2099 if No
(Decls
) or else Is_Empty_List
(Decls
) then
2103 -- Process all declarations in reverse order
2105 Decl
:= Last_Non_Pragma
(Decls
);
2106 while Present
(Decl
) loop
2108 -- Library-level tagged types
2110 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2111 Typ
:= Defining_Identifier
(Decl
);
2113 -- Ignored Ghost types do not need any cleanup actions because
2114 -- they will not appear in the final tree.
2116 if Is_Ignored_Ghost_Entity
(Typ
) then
2119 elsif Is_Tagged_Type
(Typ
)
2120 and then Is_Library_Level_Entity
(Typ
)
2121 and then Convention
(Typ
) = Convention_Ada
2122 and then Present
(Access_Disp_Table
(Typ
))
2123 and then RTE_Available
(RE_Register_Tag
)
2124 and then not Is_Abstract_Type
(Typ
)
2125 and then not No_Run_Time_Mode
2130 -- Regular object declarations
2132 elsif Nkind
(Decl
) = N_Object_Declaration
then
2133 Obj_Id
:= Defining_Identifier
(Decl
);
2134 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2135 Expr
:= Expression
(Decl
);
2137 -- Bypass any form of processing for objects which have their
2138 -- finalization disabled. This applies only to objects at the
2141 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2144 -- Finalization of transient objects are treated separately in
2145 -- order to handle sensitive cases. These include:
2147 -- * Aggregate expansion
2148 -- * If, case, and expression with actions expansion
2149 -- * Transient scopes
2151 -- If one of those contexts has marked the transient object as
2152 -- ignored, do not generate finalization actions for it.
2154 elsif Is_Finalized_Transient
(Obj_Id
)
2155 or else Is_Ignored_Transient
(Obj_Id
)
2159 -- Ignored Ghost objects do not need any cleanup actions
2160 -- because they will not appear in the final tree.
2162 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2165 -- The object is of the form:
2166 -- Obj : [constant] Typ [:= Expr];
2168 -- Do not process tag-to-class-wide conversions because they do
2169 -- not yield an object. Do not process the incomplete view of a
2170 -- deferred constant. Note that an object initialized by means
2171 -- of a build-in-place function call may appear as a deferred
2172 -- constant after expansion activities. These kinds of objects
2173 -- must be finalized.
2175 elsif not Is_Imported
(Obj_Id
)
2176 and then Needs_Finalization
(Obj_Typ
)
2177 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2178 and then not (Ekind
(Obj_Id
) = E_Constant
2179 and then not Has_Completion
(Obj_Id
)
2180 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2184 -- The object is of the form:
2185 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2187 -- Obj : Access_Typ :=
2188 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2190 elsif Is_Access_Type
(Obj_Typ
)
2191 and then Needs_Finalization
2192 (Available_View
(Designated_Type
(Obj_Typ
)))
2193 and then Present
(Expr
)
2195 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2197 (Is_Non_BIP_Func_Call
(Expr
)
2198 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2200 Processing_Actions
(Has_No_Init
=> True);
2202 -- Processing for "hook" objects generated for transient
2203 -- objects declared inside an Expression_With_Actions.
2205 elsif Is_Access_Type
(Obj_Typ
)
2206 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2207 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2208 N_Object_Declaration
2210 Processing_Actions
(Has_No_Init
=> True);
2212 -- Process intermediate results of an if expression with one
2213 -- of the alternatives using a controlled function call.
2215 elsif Is_Access_Type
(Obj_Typ
)
2216 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2217 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2218 N_Defining_Identifier
2219 and then Present
(Expr
)
2220 and then Nkind
(Expr
) = N_Null
2222 Processing_Actions
(Has_No_Init
=> True);
2224 -- Simple protected objects which use type System.Tasking.
2225 -- Protected_Objects.Protection to manage their locks should
2226 -- be treated as controlled since they require manual cleanup.
2227 -- The only exception is illustrated in the following example:
2230 -- type Ctrl is new Controlled ...
2231 -- procedure Finalize (Obj : in out Ctrl);
2235 -- package body Pkg is
2236 -- protected Prot is
2237 -- procedure Do_Something (Obj : in out Ctrl);
2240 -- protected body Prot is
2241 -- procedure Do_Something (Obj : in out Ctrl) is ...
2244 -- procedure Finalize (Obj : in out Ctrl) is
2246 -- Prot.Do_Something (Obj);
2250 -- Since for the most part entities in package bodies depend on
2251 -- those in package specs, Prot's lock should be cleaned up
2252 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2253 -- This act however attempts to invoke Do_Something and fails
2254 -- because the lock has disappeared.
2256 elsif Ekind
(Obj_Id
) = E_Variable
2257 and then not In_Library_Level_Package_Body
(Obj_Id
)
2258 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2259 or else Has_Simple_Protected_Object
(Obj_Typ
))
2261 Processing_Actions
(Is_Protected
=> True);
2264 -- Specific cases of object renamings
2266 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2267 Obj_Id
:= Defining_Identifier
(Decl
);
2268 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2270 -- Bypass any form of processing for objects which have their
2271 -- finalization disabled. This applies only to objects at the
2274 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2277 -- Ignored Ghost object renamings do not need any cleanup
2278 -- actions because they will not appear in the final tree.
2280 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2283 -- Return object of a build-in-place function. This case is
2284 -- recognized and marked by the expansion of an extended return
2285 -- statement (see Expand_N_Extended_Return_Statement).
2287 elsif Needs_Finalization
(Obj_Typ
)
2288 and then Is_Return_Object
(Obj_Id
)
2289 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2291 Processing_Actions
(Has_No_Init
=> True);
2293 -- Detect a case where a source object has been initialized by
2294 -- a controlled function call or another object which was later
2295 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2297 -- Obj1 : CW_Type := Src_Obj;
2298 -- Obj2 : CW_Type := Function_Call (...);
2300 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2301 -- Tmp : ... := Function_Call (...)'reference;
2302 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2304 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2305 Processing_Actions
(Has_No_Init
=> True);
2308 -- Inspect the freeze node of an access-to-controlled type and
2309 -- look for a delayed finalization master. This case arises when
2310 -- the freeze actions are inserted at a later time than the
2311 -- expansion of the context. Since Build_Finalizer is never called
2312 -- on a single construct twice, the master will be ultimately
2313 -- left out and never finalized. This is also needed for freeze
2314 -- actions of designated types themselves, since in some cases the
2315 -- finalization master is associated with a designated type's
2316 -- freeze node rather than that of the access type (see handling
2317 -- for freeze actions in Build_Finalization_Master).
2319 elsif Nkind
(Decl
) = N_Freeze_Entity
2320 and then Present
(Actions
(Decl
))
2322 Typ
:= Entity
(Decl
);
2324 -- Freeze nodes for ignored Ghost types do not need cleanup
2325 -- actions because they will never appear in the final tree.
2327 if Is_Ignored_Ghost_Entity
(Typ
) then
2330 elsif (Is_Access_Type
(Typ
)
2331 and then not Is_Access_Subprogram_Type
(Typ
)
2332 and then Needs_Finalization
2333 (Available_View
(Designated_Type
(Typ
))))
2334 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2336 Old_Counter_Val
:= Counter_Val
;
2338 -- Freeze nodes are considered to be identical to packages
2339 -- and blocks in terms of nesting. The difference is that
2340 -- a finalization master created inside the freeze node is
2341 -- at the same nesting level as the node itself.
2343 Process_Declarations
(Actions
(Decl
), Preprocess
);
2345 -- The freeze node contains a finalization master
2349 and then No
(Last_Top_Level_Ctrl_Construct
)
2350 and then Counter_Val
> Old_Counter_Val
2352 Last_Top_Level_Ctrl_Construct
:= Decl
;
2356 -- Nested package declarations, avoid generics
2358 elsif Nkind
(Decl
) = N_Package_Declaration
then
2359 Pack_Id
:= Defining_Entity
(Decl
);
2360 Spec
:= Specification
(Decl
);
2362 -- Do not inspect an ignored Ghost package because all code
2363 -- found within will not appear in the final tree.
2365 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2368 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2369 Old_Counter_Val
:= Counter_Val
;
2370 Process_Declarations
2371 (Private_Declarations
(Spec
), Preprocess
);
2372 Process_Declarations
2373 (Visible_Declarations
(Spec
), Preprocess
);
2375 -- Either the visible or the private declarations contain a
2376 -- controlled object. The nested package declaration is the
2377 -- last such construct.
2381 and then No
(Last_Top_Level_Ctrl_Construct
)
2382 and then Counter_Val
> Old_Counter_Val
2384 Last_Top_Level_Ctrl_Construct
:= Decl
;
2388 -- Nested package bodies, avoid generics
2390 elsif Nkind
(Decl
) = N_Package_Body
then
2392 -- Do not inspect an ignored Ghost package body because all
2393 -- code found within will not appear in the final tree.
2395 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2398 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2401 Old_Counter_Val
:= Counter_Val
;
2402 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2404 -- The nested package body is the last construct to contain
2405 -- a controlled object.
2409 and then No
(Last_Top_Level_Ctrl_Construct
)
2410 and then Counter_Val
> Old_Counter_Val
2412 Last_Top_Level_Ctrl_Construct
:= Decl
;
2416 -- Handle a rare case caused by a controlled transient object
2417 -- created as part of a record init proc. The variable is wrapped
2418 -- in a block, but the block is not associated with a transient
2421 elsif Nkind
(Decl
) = N_Block_Statement
2422 and then Inside_Init_Proc
2424 Old_Counter_Val
:= Counter_Val
;
2426 if Present
(Handled_Statement_Sequence
(Decl
)) then
2427 Process_Declarations
2428 (Statements
(Handled_Statement_Sequence
(Decl
)),
2432 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2434 -- Either the declaration or statement list of the block has a
2435 -- controlled object.
2439 and then No
(Last_Top_Level_Ctrl_Construct
)
2440 and then Counter_Val
> Old_Counter_Val
2442 Last_Top_Level_Ctrl_Construct
:= Decl
;
2445 -- Handle the case where the original context has been wrapped in
2446 -- a block to avoid interference between exception handlers and
2447 -- At_End handlers. Treat the block as transparent and process its
2450 elsif Nkind
(Decl
) = N_Block_Statement
2451 and then Is_Finalization_Wrapper
(Decl
)
2453 if Present
(Handled_Statement_Sequence
(Decl
)) then
2454 Process_Declarations
2455 (Statements
(Handled_Statement_Sequence
(Decl
)),
2459 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2462 Prev_Non_Pragma
(Decl
);
2464 end Process_Declarations
;
2466 --------------------------------
2467 -- Process_Object_Declaration --
2468 --------------------------------
2470 procedure Process_Object_Declaration
2472 Has_No_Init
: Boolean := False;
2473 Is_Protected
: Boolean := False)
2475 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2476 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2478 Init_Typ
: Entity_Id
;
2479 -- The initialization type of the related object declaration. Note
2480 -- that this is not necessarily the same type as Obj_Typ because of
2481 -- possible type derivations.
2483 Obj_Typ
: Entity_Id
;
2484 -- The type of the related object declaration
2486 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2487 -- Func_Id denotes a build-in-place function. Generate the following
2490 -- if BIPallocfrom > Secondary_Stack'Pos
2491 -- and then BIPfinalizationmaster /= null
2494 -- type Ptr_Typ is access Obj_Typ;
2495 -- for Ptr_Typ'Storage_Pool
2496 -- use Base_Pool (BIPfinalizationmaster);
2498 -- Free (Ptr_Typ (Temp));
2502 -- Obj_Typ is the type of the current object, Temp is the original
2503 -- allocation which Obj_Id renames.
2505 procedure Find_Last_Init
2506 (Last_Init
: out Node_Id
;
2507 Body_Insert
: out Node_Id
);
2508 -- Find the last initialization call related to object declaration
2509 -- Decl. Last_Init denotes the last initialization call which follows
2510 -- Decl. Body_Insert denotes a node where the finalizer body could be
2511 -- potentially inserted after (if blocks are involved).
2513 -----------------------------
2514 -- Build_BIP_Cleanup_Stmts --
2515 -----------------------------
2517 function Build_BIP_Cleanup_Stmts
2518 (Func_Id
: Entity_Id
) return Node_Id
2520 Decls
: constant List_Id
:= New_List
;
2521 Fin_Mas_Id
: constant Entity_Id
:=
2522 Build_In_Place_Formal
2523 (Func_Id
, BIP_Finalization_Master
);
2524 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2525 Temp_Id
: constant Entity_Id
:=
2526 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2530 Free_Stmt
: Node_Id
;
2531 Pool_Id
: Entity_Id
;
2532 Ptr_Typ
: Entity_Id
;
2536 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2538 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2541 Make_Object_Renaming_Declaration
(Loc
,
2542 Defining_Identifier
=> Pool_Id
,
2544 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2546 Make_Explicit_Dereference
(Loc
,
2548 Make_Function_Call
(Loc
,
2550 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2551 Parameter_Associations
=> New_List
(
2552 Make_Explicit_Dereference
(Loc
,
2554 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2556 -- Create an access type which uses the storage pool of the
2557 -- caller's finalization master.
2560 -- type Ptr_Typ is access Func_Typ;
2562 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2565 Make_Full_Type_Declaration
(Loc
,
2566 Defining_Identifier
=> Ptr_Typ
,
2568 Make_Access_To_Object_Definition
(Loc
,
2569 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2571 -- Perform minor decoration in order to set the master and the
2572 -- storage pool attributes.
2574 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2575 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2576 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2578 -- Create an explicit free statement. Note that the free uses the
2579 -- caller's pool expressed as a renaming.
2582 Make_Free_Statement
(Loc
,
2584 Unchecked_Convert_To
(Ptr_Typ
,
2585 New_Occurrence_Of
(Temp_Id
, Loc
)));
2587 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2589 -- Create a block to house the dummy type and the instantiation as
2590 -- well as to perform the cleanup the temporary.
2596 -- Free (Ptr_Typ (Temp_Id));
2600 Make_Block_Statement
(Loc
,
2601 Declarations
=> Decls
,
2602 Handled_Statement_Sequence
=>
2603 Make_Handled_Sequence_Of_Statements
(Loc
,
2604 Statements
=> New_List
(Free_Stmt
)));
2607 -- if BIPfinalizationmaster /= null then
2611 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2612 Right_Opnd
=> Make_Null
(Loc
));
2614 -- For constrained or tagged results escalate the condition to
2615 -- include the allocation format. Generate:
2617 -- if BIPallocform > Secondary_Stack'Pos
2618 -- and then BIPfinalizationmaster /= null
2621 if not Is_Constrained
(Func_Typ
)
2622 or else Is_Tagged_Type
(Func_Typ
)
2625 Alloc
: constant Entity_Id
:=
2626 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2632 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2634 Make_Integer_Literal
(Loc
,
2636 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2638 Right_Opnd
=> Cond
);
2648 Make_If_Statement
(Loc
,
2650 Then_Statements
=> New_List
(Free_Blk
));
2651 end Build_BIP_Cleanup_Stmts
;
2653 --------------------
2654 -- Find_Last_Init --
2655 --------------------
2657 procedure Find_Last_Init
2658 (Last_Init
: out Node_Id
;
2659 Body_Insert
: out Node_Id
)
2661 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2662 -- Find the last initialization call within the statements of
2665 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2666 -- Determine whether node N denotes one of the initialization
2667 -- procedures of types Init_Typ or Obj_Typ.
2669 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2670 -- Obtain the next statement which follows list member Stmt while
2671 -- ignoring artifacts related to access-before-elaboration checks.
2673 -----------------------------
2674 -- Find_Last_Init_In_Block --
2675 -----------------------------
2677 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2678 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2682 -- Examine the individual statements of the block in reverse to
2683 -- locate the last initialization call.
2685 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2686 Stmt
:= Last
(Statements
(HSS
));
2687 while Present
(Stmt
) loop
2689 -- Peek inside nested blocks in case aborts are allowed
2691 if Nkind
(Stmt
) = N_Block_Statement
then
2692 return Find_Last_Init_In_Block
(Stmt
);
2694 elsif Is_Init_Call
(Stmt
) then
2703 end Find_Last_Init_In_Block
;
2709 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2710 function Is_Init_Proc_Of
2711 (Subp_Id
: Entity_Id
;
2712 Typ
: Entity_Id
) return Boolean;
2713 -- Determine whether subprogram Subp_Id is a valid init proc of
2716 ---------------------
2717 -- Is_Init_Proc_Of --
2718 ---------------------
2720 function Is_Init_Proc_Of
2721 (Subp_Id
: Entity_Id
;
2722 Typ
: Entity_Id
) return Boolean
2724 Deep_Init
: Entity_Id
:= Empty
;
2725 Prim_Init
: Entity_Id
:= Empty
;
2726 Type_Init
: Entity_Id
:= Empty
;
2729 -- Obtain all possible initialization routines of the
2730 -- related type and try to match the subprogram entity
2731 -- against one of them.
2735 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2737 -- Primitive Initialize
2739 if Is_Controlled
(Typ
) then
2740 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2742 if Present
(Prim_Init
) then
2743 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2747 -- Type initialization routine
2749 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2750 Type_Init
:= Base_Init_Proc
(Typ
);
2754 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2756 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2758 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2759 end Is_Init_Proc_Of
;
2763 Call_Id
: Entity_Id
;
2765 -- Start of processing for Is_Init_Call
2768 if Nkind
(N
) = N_Procedure_Call_Statement
2769 and then Nkind
(Name
(N
)) = N_Identifier
2771 Call_Id
:= Entity
(Name
(N
));
2773 -- Consider both the type of the object declaration and its
2774 -- related initialization type.
2777 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2779 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2785 -----------------------------
2786 -- Next_Suitable_Statement --
2787 -----------------------------
2789 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2793 -- Skip call markers and Program_Error raises installed by the
2796 Result
:= Next
(Stmt
);
2797 while Present
(Result
) loop
2798 if not Nkind_In
(Result
, N_Call_Marker
,
2799 N_Raise_Program_Error
)
2804 Result
:= Next
(Result
);
2808 end Next_Suitable_Statement
;
2816 Deep_Init_Found
: Boolean := False;
2817 -- A flag set when a call to [Deep_]Initialize has been found
2819 -- Start of processing for Find_Last_Init
2823 Body_Insert
:= Empty
;
2825 -- Object renamings and objects associated with controlled
2826 -- function results do not require initialization.
2832 Stmt
:= Next_Suitable_Statement
(Decl
);
2834 -- For an object with suppressed initialization, we check whether
2835 -- there is in fact no initialization expression. If there is not,
2836 -- then this is an object declaration that has been turned into a
2837 -- different object declaration that calls the build-in-place
2838 -- function in a 'Reference attribute, as in "F(...)'Reference".
2839 -- We search for that later object declaration, so that the
2840 -- Inc_Decl will be inserted after the call. Otherwise, if the
2841 -- call raises an exception, we will finalize the (uninitialized)
2842 -- object, which is wrong.
2844 if No_Initialization
(Decl
) then
2845 if No
(Expression
(Last_Init
)) then
2847 Last_Init
:= Next
(Last_Init
);
2848 exit when No
(Last_Init
);
2849 exit when Nkind
(Last_Init
) = N_Object_Declaration
2850 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2851 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2853 and then Is_Expanded_Build_In_Place_Call
2854 (Prefix
(Expression
(Last_Init
)));
2860 -- In all other cases the initialization calls follow the related
2861 -- object. The general structure of object initialization built by
2862 -- routine Default_Initialize_Object is as follows:
2864 -- [begin -- aborts allowed
2866 -- Type_Init_Proc (Obj);
2867 -- [begin] -- exceptions allowed
2868 -- Deep_Initialize (Obj);
2869 -- [exception -- exceptions allowed
2871 -- Deep_Finalize (Obj, Self => False);
2874 -- [at end -- aborts allowed
2878 -- When aborts are allowed, the initialization calls are housed
2881 elsif Nkind
(Stmt
) = N_Block_Statement
then
2882 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2883 Body_Insert
:= Stmt
;
2885 -- Otherwise the initialization calls follow the related object
2888 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2890 -- Check for an optional call to Deep_Initialize which may
2891 -- appear within a block depending on whether the object has
2892 -- controlled components.
2894 if Present
(Stmt_2
) then
2895 if Nkind
(Stmt_2
) = N_Block_Statement
then
2896 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2898 if Present
(Call
) then
2899 Deep_Init_Found
:= True;
2901 Body_Insert
:= Stmt_2
;
2904 elsif Is_Init_Call
(Stmt_2
) then
2905 Deep_Init_Found
:= True;
2906 Last_Init
:= Stmt_2
;
2907 Body_Insert
:= Last_Init
;
2911 -- If the object lacks a call to Deep_Initialize, then it must
2912 -- have a call to its related type init proc.
2914 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2916 Body_Insert
:= Last_Init
;
2924 Count_Ins
: Node_Id
;
2926 Fin_Stmts
: List_Id
:= No_List
;
2929 Label_Id
: Entity_Id
;
2932 -- Start of processing for Process_Object_Declaration
2935 -- Handle the object type and the reference to the object
2937 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2938 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2941 if Is_Access_Type
(Obj_Typ
) then
2942 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2943 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2945 elsif Is_Concurrent_Type
(Obj_Typ
)
2946 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2948 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2949 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2951 elsif Is_Private_Type
(Obj_Typ
)
2952 and then Present
(Full_View
(Obj_Typ
))
2954 Obj_Typ
:= Full_View
(Obj_Typ
);
2955 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2957 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2958 Obj_Typ
:= Base_Type
(Obj_Typ
);
2959 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2966 Set_Etype
(Obj_Ref
, Obj_Typ
);
2968 -- Handle the initialization type of the object declaration
2970 Init_Typ
:= Obj_Typ
;
2972 if Is_Private_Type
(Init_Typ
)
2973 and then Present
(Full_View
(Init_Typ
))
2975 Init_Typ
:= Full_View
(Init_Typ
);
2977 elsif Is_Untagged_Derivation
(Init_Typ
) then
2978 Init_Typ
:= Root_Type
(Init_Typ
);
2985 -- Set a new value for the state counter and insert the statement
2986 -- after the object declaration. Generate:
2988 -- Counter := <value>;
2991 Make_Assignment_Statement
(Loc
,
2992 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2993 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2995 -- Insert the counter after all initialization has been done. The
2996 -- place of insertion depends on the context.
2998 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
) then
3000 -- The object is initialized by a build-in-place function call.
3001 -- The counter insertion point is after the function call.
3003 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3004 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3007 -- The object is initialized by an aggregate. Insert the counter
3008 -- after the last aggregate assignment.
3010 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3011 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3014 -- In all other cases the counter is inserted after the last call
3015 -- to either [Deep_]Initialize or the type-specific init proc.
3018 Find_Last_Init
(Count_Ins
, Body_Ins
);
3021 -- In all other cases the counter is inserted after the last call to
3022 -- either [Deep_]Initialize or the type-specific init proc.
3025 Find_Last_Init
(Count_Ins
, Body_Ins
);
3028 -- If the Initialize function is null or trivial, the call will have
3029 -- been replaced with a null statement, in which case place counter
3030 -- declaration after object declaration itself.
3032 if No
(Count_Ins
) then
3036 Insert_After
(Count_Ins
, Inc_Decl
);
3039 -- If the current declaration is the last in the list, the finalizer
3040 -- body needs to be inserted after the set counter statement for the
3041 -- current object declaration. This is complicated by the fact that
3042 -- the set counter statement may appear in abort deferred block. In
3043 -- that case, the proper insertion place is after the block.
3045 if No
(Finalizer_Insert_Nod
) then
3047 -- Insertion after an abort deferred block
3049 if Present
(Body_Ins
) then
3050 Finalizer_Insert_Nod
:= Body_Ins
;
3052 Finalizer_Insert_Nod
:= Inc_Decl
;
3056 -- Create the associated label with this object, generate:
3058 -- L<counter> : label;
3061 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3063 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3064 Label
:= Make_Label
(Loc
, Label_Id
);
3066 Prepend_To
(Finalizer_Decls
,
3067 Make_Implicit_Label_Declaration
(Loc
,
3068 Defining_Identifier
=> Entity
(Label_Id
),
3069 Label_Construct
=> Label
));
3071 -- Create the associated jump with this object, generate:
3073 -- when <counter> =>
3076 Prepend_To
(Jump_Alts
,
3077 Make_Case_Statement_Alternative
(Loc
,
3078 Discrete_Choices
=> New_List
(
3079 Make_Integer_Literal
(Loc
, Counter_Val
)),
3080 Statements
=> New_List
(
3081 Make_Goto_Statement
(Loc
,
3082 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3084 -- Insert the jump destination, generate:
3088 Append_To
(Finalizer_Stmts
, Label
);
3090 -- Processing for simple protected objects. Such objects require
3091 -- manual finalization of their lock managers.
3093 if Is_Protected
then
3094 if Is_Simple_Protected_Type
(Obj_Typ
) then
3095 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3097 if Present
(Fin_Call
) then
3098 Fin_Stmts
:= New_List
(Fin_Call
);
3101 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3102 if Is_Record_Type
(Obj_Typ
) then
3103 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3104 elsif Is_Array_Type
(Obj_Typ
) then
3105 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3111 -- System.Tasking.Protected_Objects.Finalize_Protection
3119 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3120 Fin_Stmts
:= New_List
(
3121 Make_Block_Statement
(Loc
,
3122 Handled_Statement_Sequence
=>
3123 Make_Handled_Sequence_Of_Statements
(Loc
,
3124 Statements
=> Fin_Stmts
,
3126 Exception_Handlers
=> New_List
(
3127 Make_Exception_Handler
(Loc
,
3128 Exception_Choices
=> New_List
(
3129 Make_Others_Choice
(Loc
)),
3131 Statements
=> New_List
(
3132 Make_Null_Statement
(Loc
)))))));
3135 -- Processing for regular controlled objects
3140 -- [Deep_]Finalize (Obj);
3143 -- when Id : others =>
3144 -- if not Raised then
3146 -- Save_Occurrence (E, Id);
3155 -- Guard against a missing [Deep_]Finalize when the object type
3156 -- was not properly frozen.
3158 if No
(Fin_Call
) then
3159 Fin_Call
:= Make_Null_Statement
(Loc
);
3162 -- For CodePeer, the exception handlers normally generated here
3163 -- generate complex flowgraphs which result in capacity problems.
3164 -- Omitting these handlers for CodePeer is justified as follows:
3166 -- If a handler is dead, then omitting it is surely ok
3168 -- If a handler is live, then CodePeer should flag the
3169 -- potentially-exception-raising construct that causes it
3170 -- to be live. That is what we are interested in, not what
3171 -- happens after the exception is raised.
3173 if Exceptions_OK
and not CodePeer_Mode
then
3174 Fin_Stmts
:= New_List
(
3175 Make_Block_Statement
(Loc
,
3176 Handled_Statement_Sequence
=>
3177 Make_Handled_Sequence_Of_Statements
(Loc
,
3178 Statements
=> New_List
(Fin_Call
),
3180 Exception_Handlers
=> New_List
(
3181 Build_Exception_Handler
3182 (Finalizer_Data
, For_Package
)))));
3184 -- When exception handlers are prohibited, the finalization call
3185 -- appears unprotected. Any exception raised during finalization
3186 -- will bypass the circuitry which ensures the cleanup of all
3187 -- remaining objects.
3190 Fin_Stmts
:= New_List
(Fin_Call
);
3193 -- If we are dealing with a return object of a build-in-place
3194 -- function, generate the following cleanup statements:
3196 -- if BIPallocfrom > Secondary_Stack'Pos
3197 -- and then BIPfinalizationmaster /= null
3200 -- type Ptr_Typ is access Obj_Typ;
3201 -- for Ptr_Typ'Storage_Pool use
3202 -- Base_Pool (BIPfinalizationmaster.all).all;
3204 -- Free (Ptr_Typ (Temp));
3208 -- The generated code effectively detaches the temporary from the
3209 -- caller finalization master and deallocates the object.
3211 if Is_Return_Object
(Obj_Id
) then
3213 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3215 if Is_Build_In_Place_Function
(Func_Id
)
3216 and then Needs_BIP_Finalization_Master
(Func_Id
)
3218 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3223 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
3224 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3226 -- Temporaries created for the purpose of "exporting" a
3227 -- transient object out of an Expression_With_Actions (EWA)
3228 -- need guards. The following illustrates the usage of such
3231 -- Access_Typ : access [all] Obj_Typ;
3232 -- Temp : Access_Typ := null;
3233 -- <Counter> := ...;
3236 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3237 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3239 -- Temp := Ctrl_Trans'Unchecked_Access;
3242 -- The finalization machinery does not process EWA nodes as
3243 -- this may lead to premature finalization of expressions. Note
3244 -- that Temp is marked as being properly initialized regardless
3245 -- of whether the initialization of Ctrl_Trans succeeded. Since
3246 -- a failed initialization may leave Temp with a value of null,
3247 -- add a guard to handle this case:
3249 -- if Obj /= null then
3250 -- <object finalization statements>
3253 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3254 N_Object_Declaration
3256 Fin_Stmts
:= New_List
(
3257 Make_If_Statement
(Loc
,
3260 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3261 Right_Opnd
=> Make_Null
(Loc
)),
3262 Then_Statements
=> Fin_Stmts
));
3264 -- Return objects use a flag to aid in processing their
3265 -- potential finalization when the enclosing function fails
3266 -- to return properly. Generate:
3269 -- <object finalization statements>
3273 Fin_Stmts
:= New_List
(
3274 Make_If_Statement
(Loc
,
3279 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3281 Then_Statements
=> Fin_Stmts
));
3286 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3288 -- Since the declarations are examined in reverse, the state counter
3289 -- must be decremented in order to keep with the true position of
3292 Counter_Val
:= Counter_Val
- 1;
3293 end Process_Object_Declaration
;
3295 -------------------------------------
3296 -- Process_Tagged_Type_Declaration --
3297 -------------------------------------
3299 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3300 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3301 DT_Ptr
: constant Entity_Id
:=
3302 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3305 -- Ada.Tags.Unregister_Tag (<Typ>P);
3307 Append_To
(Tagged_Type_Stmts
,
3308 Make_Procedure_Call_Statement
(Loc
,
3310 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3311 Parameter_Associations
=> New_List
(
3312 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3313 end Process_Tagged_Type_Declaration
;
3315 -- Start of processing for Build_Finalizer
3320 -- Do not perform this expansion in SPARK mode because it is not
3323 if GNATprove_Mode
then
3327 -- Step 1: Extract all lists which may contain controlled objects or
3328 -- library-level tagged types.
3330 if For_Package_Spec
then
3331 Decls
:= Visible_Declarations
(Specification
(N
));
3332 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3334 -- Retrieve the package spec id
3336 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3338 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3339 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3342 -- Accept statement, block, entry body, package body, protected body,
3343 -- subprogram body or task body.
3346 Decls
:= Declarations
(N
);
3347 HSS
:= Handled_Statement_Sequence
(N
);
3349 if Present
(HSS
) then
3350 if Present
(Statements
(HSS
)) then
3351 Stmts
:= Statements
(HSS
);
3354 if Present
(At_End_Proc
(HSS
)) then
3355 Prev_At_End
:= At_End_Proc
(HSS
);
3359 -- Retrieve the package spec id for package bodies
3361 if For_Package_Body
then
3362 Spec_Id
:= Corresponding_Spec
(N
);
3366 -- Do not process nested packages since those are handled by the
3367 -- enclosing scope's finalizer. Do not process non-expanded package
3368 -- instantiations since those will be re-analyzed and re-expanded.
3372 (not Is_Library_Level_Entity
(Spec_Id
)
3374 -- Nested packages are considered to be library level entities,
3375 -- but do not need to be processed separately. True library level
3376 -- packages have a scope value of 1.
3378 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3379 or else (Is_Generic_Instance
(Spec_Id
)
3380 and then Package_Instantiation
(Spec_Id
) /= N
))
3385 -- Step 2: Object [pre]processing
3389 -- Preprocess the visible declarations now in order to obtain the
3390 -- correct number of controlled object by the time the private
3391 -- declarations are processed.
3393 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3395 -- From all the possible contexts, only package specifications may
3396 -- have private declarations.
3398 if For_Package_Spec
then
3399 Process_Declarations
3400 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3403 -- The current context may lack controlled objects, but require some
3404 -- other form of completion (task termination for instance). In such
3405 -- cases, the finalizer must be created and carry the additional
3408 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3412 -- The preprocessing has determined that the context has controlled
3413 -- objects or library-level tagged types.
3415 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3417 -- Private declarations are processed first in order to preserve
3418 -- possible dependencies between public and private objects.
3420 if For_Package_Spec
then
3421 Process_Declarations
(Priv_Decls
);
3424 Process_Declarations
(Decls
);
3430 -- Preprocess both declarations and statements
3432 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3433 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3435 -- At this point it is known that N has controlled objects. Ensure
3436 -- that N has a declarative list since the finalizer spec will be
3439 if Has_Ctrl_Objs
and then No
(Decls
) then
3440 Set_Declarations
(N
, New_List
);
3441 Decls
:= Declarations
(N
);
3442 Spec_Decls
:= Decls
;
3445 -- The current context may lack controlled objects, but require some
3446 -- other form of completion (task termination for instance). In such
3447 -- cases, the finalizer must be created and carry the additional
3450 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3454 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3455 Process_Declarations
(Stmts
);
3456 Process_Declarations
(Decls
);
3460 -- Step 3: Finalizer creation
3462 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3465 end Build_Finalizer
;
3467 --------------------------
3468 -- Build_Finalizer_Call --
3469 --------------------------
3471 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3472 Is_Prot_Body
: constant Boolean :=
3473 Nkind
(N
) = N_Subprogram_Body
3474 and then Is_Protected_Subprogram_Body
(N
);
3475 -- Determine whether N denotes the protected version of a subprogram
3476 -- which belongs to a protected type.
3478 Loc
: constant Source_Ptr
:= Sloc
(N
);
3482 -- Do not perform this expansion in SPARK mode because we do not create
3483 -- finalizers in the first place.
3485 if GNATprove_Mode
then
3489 -- The At_End handler should have been assimilated by the finalizer
3491 HSS
:= Handled_Statement_Sequence
(N
);
3492 pragma Assert
(No
(At_End_Proc
(HSS
)));
3494 -- If the construct to be cleaned up is a protected subprogram body, the
3495 -- finalizer call needs to be associated with the block which wraps the
3496 -- unprotected version of the subprogram. The following illustrates this
3499 -- procedure Prot_SubpP is
3500 -- procedure finalizer is
3502 -- Service_Entries (Prot_Obj);
3509 -- Prot_SubpN (Prot_Obj);
3515 if Is_Prot_Body
then
3516 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3518 -- An At_End handler and regular exception handlers cannot coexist in
3519 -- the same statement sequence. Wrap the original statements in a block.
3521 elsif Present
(Exception_Handlers
(HSS
)) then
3523 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3528 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3530 Set_Handled_Statement_Sequence
(N
,
3531 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3533 HSS
:= Handled_Statement_Sequence
(N
);
3534 Set_End_Label
(HSS
, End_Lab
);
3538 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3540 -- Attach reference to finalizer to tree, for LLVM use
3542 Set_Parent
(At_End_Proc
(HSS
), HSS
);
3544 Analyze
(At_End_Proc
(HSS
));
3545 Expand_At_End_Handler
(HSS
, Empty
);
3546 end Build_Finalizer_Call
;
3548 ---------------------
3549 -- Build_Late_Proc --
3550 ---------------------
3552 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3554 for Final_Prim
in Name_Of
'Range loop
3555 if Name_Of
(Final_Prim
) = Nam
then
3558 (Prim
=> Final_Prim
,
3560 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3563 end Build_Late_Proc
;
3565 -------------------------------
3566 -- Build_Object_Declarations --
3567 -------------------------------
3569 procedure Build_Object_Declarations
3570 (Data
: out Finalization_Exception_Data
;
3573 For_Package
: Boolean := False)
3578 -- This variable captures an unused dummy internal entity, see the
3579 -- comment associated with its use.
3582 pragma Assert
(Decls
/= No_List
);
3584 -- Always set the proper location as it may be needed even when
3585 -- exception propagation is forbidden.
3589 if Restriction_Active
(No_Exception_Propagation
) then
3590 Data
.Abort_Id
:= Empty
;
3592 Data
.Raised_Id
:= Empty
;
3596 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3598 -- In certain scenarios, finalization can be triggered by an abort. If
3599 -- the finalization itself fails and raises an exception, the resulting
3600 -- Program_Error must be supressed and replaced by an abort signal. In
3601 -- order to detect this scenario, save the state of entry into the
3602 -- finalization code.
3604 -- This is not needed for library-level finalizers as they are called by
3605 -- the environment task and cannot be aborted.
3607 if not For_Package
then
3608 if Abort_Allowed
then
3609 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3612 -- Abort_Id : constant Boolean := <A_Expr>;
3615 Make_Object_Declaration
(Loc
,
3616 Defining_Identifier
=> Data
.Abort_Id
,
3617 Constant_Present
=> True,
3618 Object_Definition
=>
3619 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3621 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3623 -- Abort is not required
3626 -- Generate a dummy entity to ensure that the internal symbols are
3627 -- in sync when a unit is compiled with and without aborts.
3629 Dummy
:= Make_Temporary
(Loc
, 'A');
3630 Data
.Abort_Id
:= Empty
;
3633 -- Library-level finalizers
3636 Data
.Abort_Id
:= Empty
;
3639 if Exception_Extra_Info
then
3640 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3643 -- E_Id : Exception_Occurrence;
3646 Make_Object_Declaration
(Loc
,
3647 Defining_Identifier
=> Data
.E_Id
,
3648 Object_Definition
=>
3649 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3650 Set_No_Initialization
(Decl
);
3652 Append_To
(Decls
, Decl
);
3659 -- Raised_Id : Boolean := False;
3662 Make_Object_Declaration
(Loc
,
3663 Defining_Identifier
=> Data
.Raised_Id
,
3664 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3665 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3666 end Build_Object_Declarations
;
3668 ---------------------------
3669 -- Build_Raise_Statement --
3670 ---------------------------
3672 function Build_Raise_Statement
3673 (Data
: Finalization_Exception_Data
) return Node_Id
3679 -- Standard run-time use the specialized routine
3680 -- Raise_From_Controlled_Operation.
3682 if Exception_Extra_Info
3683 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3686 Make_Procedure_Call_Statement
(Data
.Loc
,
3689 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3690 Parameter_Associations
=>
3691 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3693 -- Restricted run-time: exception messages are not supported and hence
3694 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3699 Make_Raise_Program_Error
(Data
.Loc
,
3700 Reason
=> PE_Finalize_Raised_Exception
);
3705 -- Raised_Id and then not Abort_Id
3709 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3711 if Present
(Data
.Abort_Id
) then
3712 Expr
:= Make_And_Then
(Data
.Loc
,
3715 Make_Op_Not
(Data
.Loc
,
3716 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3721 -- if Raised_Id and then not Abort_Id then
3722 -- Raise_From_Controlled_Operation (E_Id);
3724 -- raise Program_Error; -- restricted runtime
3728 Make_If_Statement
(Data
.Loc
,
3730 Then_Statements
=> New_List
(Stmt
));
3731 end Build_Raise_Statement
;
3733 -----------------------------
3734 -- Build_Record_Deep_Procs --
3735 -----------------------------
3737 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3741 (Prim
=> Initialize_Case
,
3743 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3745 if not Is_Limited_View
(Typ
) then
3748 (Prim
=> Adjust_Case
,
3750 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3753 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3754 -- suppressed since these routine will not be used.
3756 if not Restriction_Active
(No_Finalization
) then
3759 (Prim
=> Finalize_Case
,
3761 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3763 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3765 if not CodePeer_Mode
then
3768 (Prim
=> Address_Case
,
3770 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3773 end Build_Record_Deep_Procs
;
3779 function Cleanup_Array
3782 Typ
: Entity_Id
) return List_Id
3784 Loc
: constant Source_Ptr
:= Sloc
(N
);
3785 Index_List
: constant List_Id
:= New_List
;
3787 function Free_Component
return List_Id
;
3788 -- Generate the code to finalize the task or protected subcomponents
3789 -- of a single component of the array.
3791 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3792 -- Generate a loop over one dimension of the array
3794 --------------------
3795 -- Free_Component --
3796 --------------------
3798 function Free_Component
return List_Id
is
3799 Stmts
: List_Id
:= New_List
;
3801 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3804 -- Component type is known to contain tasks or protected objects
3807 Make_Indexed_Component
(Loc
,
3808 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3809 Expressions
=> Index_List
);
3811 Set_Etype
(Tsk
, C_Typ
);
3813 if Is_Task_Type
(C_Typ
) then
3814 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3816 elsif Is_Simple_Protected_Type
(C_Typ
) then
3817 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3819 elsif Is_Record_Type
(C_Typ
) then
3820 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3822 elsif Is_Array_Type
(C_Typ
) then
3823 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3829 ------------------------
3830 -- Free_One_Dimension --
3831 ------------------------
3833 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3837 if Dim
> Number_Dimensions
(Typ
) then
3838 return Free_Component
;
3840 -- Here we generate the required loop
3843 Index
:= Make_Temporary
(Loc
, 'J');
3844 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3847 Make_Implicit_Loop_Statement
(N
,
3848 Identifier
=> Empty
,
3850 Make_Iteration_Scheme
(Loc
,
3851 Loop_Parameter_Specification
=>
3852 Make_Loop_Parameter_Specification
(Loc
,
3853 Defining_Identifier
=> Index
,
3854 Discrete_Subtype_Definition
=>
3855 Make_Attribute_Reference
(Loc
,
3856 Prefix
=> Duplicate_Subexpr
(Obj
),
3857 Attribute_Name
=> Name_Range
,
3858 Expressions
=> New_List
(
3859 Make_Integer_Literal
(Loc
, Dim
))))),
3860 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3862 end Free_One_Dimension
;
3864 -- Start of processing for Cleanup_Array
3867 return Free_One_Dimension
(1);
3870 --------------------
3871 -- Cleanup_Record --
3872 --------------------
3874 function Cleanup_Record
3877 Typ
: Entity_Id
) return List_Id
3879 Loc
: constant Source_Ptr
:= Sloc
(N
);
3882 Stmts
: constant List_Id
:= New_List
;
3883 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3886 if Has_Discriminants
(U_Typ
)
3887 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3888 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3891 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3893 -- For now, do not attempt to free a component that may appear in a
3894 -- variant, and instead issue a warning. Doing this "properly" would
3895 -- require building a case statement and would be quite a mess. Note
3896 -- that the RM only requires that free "work" for the case of a task
3897 -- access value, so already we go way beyond this in that we deal
3898 -- with the array case and non-discriminated record cases.
3901 ("task/protected object in variant record will not be freed??", N
);
3902 return New_List
(Make_Null_Statement
(Loc
));
3905 Comp
:= First_Component
(Typ
);
3906 while Present
(Comp
) loop
3907 if Has_Task
(Etype
(Comp
))
3908 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3911 Make_Selected_Component
(Loc
,
3912 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3913 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3914 Set_Etype
(Tsk
, Etype
(Comp
));
3916 if Is_Task_Type
(Etype
(Comp
)) then
3917 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3919 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3920 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3922 elsif Is_Record_Type
(Etype
(Comp
)) then
3924 -- Recurse, by generating the prefix of the argument to
3925 -- the eventual cleanup call.
3927 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3929 elsif Is_Array_Type
(Etype
(Comp
)) then
3930 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3934 Next_Component
(Comp
);
3940 ------------------------------
3941 -- Cleanup_Protected_Object --
3942 ------------------------------
3944 function Cleanup_Protected_Object
3946 Ref
: Node_Id
) return Node_Id
3948 Loc
: constant Source_Ptr
:= Sloc
(N
);
3951 -- For restricted run-time libraries (Ravenscar), tasks are
3952 -- non-terminating, and protected objects can only appear at library
3953 -- level, so we do not want finalization of protected objects.
3955 if Restricted_Profile
then
3960 Make_Procedure_Call_Statement
(Loc
,
3962 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3963 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3965 end Cleanup_Protected_Object
;
3971 function Cleanup_Task
3973 Ref
: Node_Id
) return Node_Id
3975 Loc
: constant Source_Ptr
:= Sloc
(N
);
3978 -- For restricted run-time libraries (Ravenscar), tasks are
3979 -- non-terminating and they can only appear at library level,
3980 -- so we do not want finalization of task objects.
3982 if Restricted_Profile
then
3987 Make_Procedure_Call_Statement
(Loc
,
3989 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3990 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3994 --------------------------------------
3995 -- Check_Unnesting_Elaboration_Code --
3996 --------------------------------------
3998 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
3999 Loc
: constant Source_Ptr
:= Sloc
(N
);
4001 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
4002 -- Check recursively whether a loop or block contains a subprogram that
4003 -- may need an activation record.
4005 function First_Local_Scope
(L
: List_Id
) return Entity_Id
;
4006 -- Find first block or loop that contains a subprogram and is not itself
4007 -- nested within another local scope.
4009 --------------------------
4010 -- Contains_Subprogram --
4011 --------------------------
4013 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4017 E
:= First_Entity
(Blk
);
4019 while Present
(E
) loop
4020 if Is_Subprogram
(E
) then
4023 elsif Ekind_In
(E
, E_Block
, E_Loop
)
4024 and then Contains_Subprogram
(E
)
4033 end Contains_Subprogram
;
4035 -----------------------
4036 -- Find_Local_Scope --
4037 -----------------------
4039 function First_Local_Scope
(L
: List_Id
) return Entity_Id
is
4045 while Present
(Stat
) loop
4046 case Nkind
(Stat
) is
4047 when N_Block_Statement
=>
4048 if Present
(Identifier
(Stat
)) then
4049 return Entity
(Identifier
(Stat
));
4052 when N_Loop_Statement
=>
4053 if Contains_Subprogram
(Entity
(Identifier
(Stat
))) then
4054 return Entity
(Identifier
(Stat
));
4057 when N_If_Statement
=>
4058 Scop
:= First_Local_Scope
(Then_Statements
(Stat
));
4060 if Present
(Scop
) then
4064 Scop
:= First_Local_Scope
(Else_Statements
(Stat
));
4066 if Present
(Scop
) then
4073 Elif
:= First
(Elsif_Parts
(Stat
));
4075 while Present
(Elif
) loop
4076 Scop
:= First_Local_Scope
(Statements
(Elif
));
4078 if Present
(Scop
) then
4086 when N_Case_Statement
=>
4090 Alt
:= First
(Alternatives
(Stat
));
4092 while Present
(Alt
) loop
4093 Scop
:= First_Local_Scope
(Statements
(Alt
));
4095 if Present
(Scop
) then
4103 when N_Subprogram_Body
=>
4104 return Defining_Entity
(Stat
);
4114 end First_Local_Scope
;
4118 Elab_Body
: Node_Id
;
4119 Elab_Call
: Node_Id
;
4120 Elab_Proc
: Entity_Id
;
4123 -- Start of processing for Check_Unnesting_Elaboration_Code
4126 if Unnest_Subprogram_Mode
4127 and then Present
(Handled_Statement_Sequence
(N
))
4128 and then Is_Compilation_Unit
(Current_Scope
)
4131 First_Local_Scope
(Statements
(Handled_Statement_Sequence
(N
)));
4133 if Present
(Ent
) then
4135 Make_Defining_Identifier
(Loc
,
4136 Chars
=> New_Internal_Name
('I'));
4139 Make_Subprogram_Body
(Loc
,
4141 Make_Procedure_Specification
(Loc
,
4142 Defining_Unit_Name
=> Elab_Proc
),
4143 Declarations
=> New_List
,
4144 Handled_Statement_Sequence
=>
4145 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4148 Make_Procedure_Call_Statement
(Loc
,
4149 Name
=> New_Occurrence_Of
(Elab_Proc
, Loc
));
4151 Append_To
(Declarations
(N
), Elab_Body
);
4152 Analyze
(Elab_Body
);
4153 Set_Has_Nested_Subprogram
(Elab_Proc
);
4155 Set_Handled_Statement_Sequence
(N
,
4156 Make_Handled_Sequence_Of_Statements
(Loc
,
4157 Statements
=> New_List
(Elab_Call
)));
4159 Analyze
(Elab_Call
);
4161 -- The scope of all blocks and loops in the elaboration code is
4162 -- now the constructed elaboration procedure. Nested subprograms
4163 -- within those blocks will have activation records if they
4164 -- contain references to entities in the enclosing block.
4166 while Present
(Ent
) loop
4167 Set_Scope
(Ent
, Elab_Proc
);
4172 end Check_Unnesting_Elaboration_Code
;
4174 -------------------------------------
4175 -- Check_Unnesting_In_Declarations --
4176 -------------------------------------
4178 procedure Check_Unnesting_In_Declarations
(N
: Node_Id
) is
4181 Inner_Decl
: Node_Id
;
4183 Local_Body
: Node_Id
;
4184 Local_Call
: Node_Id
;
4185 Local_Proc
: Entity_Id
;
4188 Local_Call
:= Empty
;
4190 if Unnest_Subprogram_Mode
4191 and then Present
(Declarations
(N
))
4192 and then Is_Compilation_Unit
(Current_Scope
)
4194 Decl
:= First
(Declarations
(N
));
4195 while Present
(Decl
) loop
4196 if Nkind
(Decl
) = N_Block_Statement
then
4197 Ent
:= First_Entity
(Entity
(Identifier
(Decl
)));
4198 Inner_Decl
:= First
(Declarations
(Decl
));
4200 while Present
(Inner_Decl
) loop
4201 if Nkind
(Inner_Decl
) = N_Subprogram_Body
then
4204 Make_Defining_Identifier
(Loc
,
4205 Chars
=> New_Internal_Name
('P'));
4208 Make_Subprogram_Body
(Loc
,
4210 Make_Procedure_Specification
(Loc
,
4211 Defining_Unit_Name
=> Local_Proc
),
4212 Declarations
=> Declarations
(Decl
),
4213 Handled_Statement_Sequence
=>
4214 Handled_Statement_Sequence
(Decl
));
4216 Rewrite
(Decl
, Local_Body
);
4218 Set_Has_Nested_Subprogram
(Local_Proc
);
4221 Make_Procedure_Call_Statement
(Loc
,
4222 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
4224 Insert_After
(Decl
, Local_Call
);
4225 Analyze
(Local_Call
);
4227 while Present
(Ent
) loop
4228 Set_Scope
(Ent
, Local_Proc
);
4240 end Check_Unnesting_In_Declarations
;
4242 ------------------------------
4243 -- Check_Visibly_Controlled --
4244 ------------------------------
4246 procedure Check_Visibly_Controlled
4247 (Prim
: Final_Primitives
;
4249 E
: in out Entity_Id
;
4250 Cref
: in out Node_Id
)
4252 Parent_Type
: Entity_Id
;
4256 if Is_Derived_Type
(Typ
)
4257 and then Comes_From_Source
(E
)
4258 and then not Present
(Overridden_Operation
(E
))
4260 -- We know that the explicit operation on the type does not override
4261 -- the inherited operation of the parent, and that the derivation
4262 -- is from a private type that is not visibly controlled.
4264 Parent_Type
:= Etype
(Typ
);
4265 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4267 if Present
(Op
) then
4270 -- Wrap the object to be initialized into the proper
4271 -- unchecked conversion, to be compatible with the operation
4274 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4275 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4277 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4281 end Check_Visibly_Controlled
;
4287 function Convert_View
4290 Ind
: Pos
:= 1) return Node_Id
4292 Fent
: Entity_Id
:= First_Entity
(Proc
);
4297 for J
in 2 .. Ind
loop
4301 Ftyp
:= Etype
(Fent
);
4303 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
4304 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4306 Atyp
:= Etype
(Arg
);
4309 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4310 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4313 and then Present
(Atyp
)
4314 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
4315 and then Base_Type
(Underlying_Type
(Atyp
)) =
4316 Base_Type
(Underlying_Type
(Ftyp
))
4318 return Unchecked_Convert_To
(Ftyp
, Arg
);
4320 -- If the argument is already a conversion, as generated by
4321 -- Make_Init_Call, set the target type to the type of the formal
4322 -- directly, to avoid spurious typing problems.
4324 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
4325 and then not Is_Class_Wide_Type
(Atyp
)
4327 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4328 Set_Etype
(Arg
, Ftyp
);
4331 -- Otherwise, introduce a conversion when the designated object
4332 -- has a type derived from the formal of the controlled routine.
4334 elsif Is_Private_Type
(Ftyp
)
4335 and then Present
(Atyp
)
4336 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4338 return Unchecked_Convert_To
(Ftyp
, Arg
);
4345 -------------------------------
4346 -- CW_Or_Has_Controlled_Part --
4347 -------------------------------
4349 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
4351 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
4352 end CW_Or_Has_Controlled_Part
;
4354 ------------------------
4355 -- Enclosing_Function --
4356 ------------------------
4358 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
4359 Func_Id
: Entity_Id
;
4363 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
4364 if Ekind
(Func_Id
) = E_Function
then
4368 Func_Id
:= Scope
(Func_Id
);
4372 end Enclosing_Function
;
4374 -------------------------------
4375 -- Establish_Transient_Scope --
4376 -------------------------------
4378 -- This procedure is called each time a transient block has to be inserted
4379 -- that is to say for each call to a function with unconstrained or tagged
4380 -- result. It creates a new scope on the scope stack in order to enclose
4381 -- all transient variables generated.
4383 procedure Establish_Transient_Scope
4385 Manage_Sec_Stack
: Boolean)
4387 procedure Create_Transient_Scope
(Constr
: Node_Id
);
4388 -- Place a new scope on the scope stack in order to service construct
4389 -- Constr. The new scope may also manage the secondary stack.
4391 procedure Delegate_Sec_Stack_Management
;
4392 -- Move the management of the secondary stack to the nearest enclosing
4395 function Find_Enclosing_Transient_Scope
return Entity_Id
;
4396 -- Examine the scope stack looking for the nearest enclosing transient
4397 -- scope. Return Empty if no such scope exists.
4399 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4400 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4402 ----------------------------
4403 -- Create_Transient_Scope --
4404 ----------------------------
4406 procedure Create_Transient_Scope
(Constr
: Node_Id
) is
4407 Loc
: constant Source_Ptr
:= Sloc
(N
);
4409 Iter_Loop
: Entity_Id
;
4410 Trans_Scop
: Entity_Id
;
4413 Trans_Scop
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4414 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4416 Push_Scope
(Trans_Scop
);
4417 Set_Node_To_Be_Wrapped
(Constr
);
4418 Set_Scope_Is_Transient
;
4420 -- The transient scope must also manage the secondary stack
4422 if Manage_Sec_Stack
then
4423 Set_Uses_Sec_Stack
(Trans_Scop
);
4424 Check_Restriction
(No_Secondary_Stack
, N
);
4426 -- The expansion of iterator loops generates references to objects
4427 -- in order to extract elements from a container:
4429 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4430 -- Obj : <object type> renames Ref.all.Element.all;
4432 -- These references are controlled and returned on the secondary
4433 -- stack. A new reference is created at each iteration of the loop
4434 -- and as a result it must be finalized and the space occupied by
4435 -- it on the secondary stack reclaimed at the end of the current
4438 -- When the context that requires a transient scope is a call to
4439 -- routine Reference, the node to be wrapped is the source object:
4441 -- for Obj of Container loop
4443 -- Routine Wrap_Transient_Declaration however does not generate
4444 -- a physical block as wrapping a declaration will kill it too
4445 -- early. To handle this peculiar case, mark the related iterator
4446 -- loop as requiring the secondary stack. This signals the
4447 -- finalization machinery to manage the secondary stack (see
4448 -- routine Process_Statements_For_Controlled_Objects).
4450 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4452 if Present
(Iter_Loop
) then
4453 Set_Uses_Sec_Stack
(Iter_Loop
);
4457 if Debug_Flag_W
then
4458 Write_Str
(" <Transient>");
4461 end Create_Transient_Scope
;
4463 -----------------------------------
4464 -- Delegate_Sec_Stack_Management --
4465 -----------------------------------
4467 procedure Delegate_Sec_Stack_Management
is
4468 Scop_Id
: Entity_Id
;
4469 Scop_Rec
: Scope_Stack_Entry
;
4472 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4473 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4474 Scop_Id
:= Scop_Rec
.Entity
;
4476 -- Prevent the search from going too far or within the scope space
4479 if Scop_Id
= Standard_Standard
then
4482 -- No transient scope should be encountered during the traversal
4483 -- because Establish_Transient_Scope should have already handled
4486 elsif Scop_Rec
.Is_Transient
then
4487 pragma Assert
(False);
4490 -- The construct which requires secondary stack management is
4491 -- always enclosed by a package or subprogram scope.
4493 elsif Is_Package_Or_Subprogram
(Scop_Id
) then
4494 Set_Uses_Sec_Stack
(Scop_Id
);
4495 Check_Restriction
(No_Secondary_Stack
, N
);
4501 -- At this point no suitable scope was found. This should never occur
4502 -- because a construct is always enclosed by a compilation unit which
4505 pragma Assert
(False);
4506 end Delegate_Sec_Stack_Management
;
4508 ------------------------------------
4509 -- Find_Enclosing_Transient_Scope --
4510 ------------------------------------
4512 function Find_Enclosing_Transient_Scope
return Entity_Id
is
4513 Scop_Id
: Entity_Id
;
4514 Scop_Rec
: Scope_Stack_Entry
;
4517 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4518 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4519 Scop_Id
:= Scop_Rec
.Entity
;
4521 -- Prevent the search from going too far or within the scope space
4524 if Scop_Id
= Standard_Standard
4525 or else Is_Package_Or_Subprogram
(Scop_Id
)
4529 elsif Scop_Rec
.Is_Transient
then
4535 end Find_Enclosing_Transient_Scope
;
4537 ------------------------------
4538 -- Is_Package_Or_Subprogram --
4539 ------------------------------
4541 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4543 return Ekind_In
(Id
, E_Entry
,
4549 end Is_Package_Or_Subprogram
;
4553 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
4556 -- Start of processing for Establish_Transient_Scope
4559 -- Do not create a new transient scope if there is an existing transient
4560 -- scope on the stack.
4562 if Present
(Trans_Id
) then
4564 -- If the transient scope was requested for purposes of managing the
4565 -- secondary stack, then the existing scope must perform this task.
4567 if Manage_Sec_Stack
then
4568 Set_Uses_Sec_Stack
(Trans_Id
);
4574 -- At this point it is known that the scope stack is free of transient
4575 -- scopes. Locate the proper construct which must be serviced by a new
4578 Context
:= Find_Transient_Context
(N
);
4580 if Present
(Context
) then
4581 if Nkind
(Context
) = N_Assignment_Statement
then
4583 -- An assignment statement with suppressed controlled semantics
4584 -- does not need a transient scope because finalization is not
4585 -- desirable at this point. Note that No_Ctrl_Actions is also
4586 -- set for non-controlled assignments to suppress dispatching
4589 if No_Ctrl_Actions
(Context
)
4590 and then Needs_Finalization
(Etype
(Name
(Context
)))
4592 -- When a controlled component is initialized by a function
4593 -- call, the result on the secondary stack is always assigned
4594 -- to the component. Signal the nearest suitable scope that it
4595 -- is safe to manage the secondary stack.
4597 if Manage_Sec_Stack
and then Within_Init_Proc
then
4598 Delegate_Sec_Stack_Management
;
4601 -- Otherwise the assignment is a normal transient context and thus
4602 -- requires a transient scope.
4605 Create_Transient_Scope
(Context
);
4611 Create_Transient_Scope
(Context
);
4614 end Establish_Transient_Scope
;
4616 ----------------------------
4617 -- Expand_Cleanup_Actions --
4618 ----------------------------
4620 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4621 pragma Assert
(Nkind_In
(N
, N_Block_Statement
,
4623 N_Extended_Return_Statement
,
4627 Scop
: constant Entity_Id
:= Current_Scope
;
4629 Is_Asynchronous_Call
: constant Boolean :=
4630 Nkind
(N
) = N_Block_Statement
4631 and then Is_Asynchronous_Call_Block
(N
);
4632 Is_Master
: constant Boolean :=
4633 Nkind
(N
) /= N_Extended_Return_Statement
4634 and then Nkind
(N
) /= N_Entry_Body
4635 and then Is_Task_Master
(N
);
4636 Is_Protected_Subp_Body
: constant Boolean :=
4637 Nkind
(N
) = N_Subprogram_Body
4638 and then Is_Protected_Subprogram_Body
(N
);
4639 Is_Task_Allocation
: constant Boolean :=
4640 Nkind
(N
) = N_Block_Statement
4641 and then Is_Task_Allocation_Block
(N
);
4642 Is_Task_Body
: constant Boolean :=
4643 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4645 -- We mark the secondary stack if it is used in this construct, and
4646 -- we're not returning a function result on the secondary stack, except
4647 -- that a build-in-place function that might or might not return on the
4648 -- secondary stack always needs a mark. A run-time test is required in
4649 -- the case where the build-in-place function has a BIP_Alloc extra
4650 -- parameter (see Create_Finalizer).
4652 Needs_Sec_Stack_Mark
: constant Boolean :=
4653 (Uses_Sec_Stack
(Scop
)
4655 not Sec_Stack_Needed_For_Return
(Scop
))
4657 (Is_Build_In_Place_Function
(Scop
)
4658 and then Needs_BIP_Alloc_Form
(Scop
));
4660 Needs_Custom_Cleanup
: constant Boolean :=
4661 Nkind
(N
) = N_Block_Statement
4662 and then Present
(Cleanup_Actions
(N
));
4664 Actions_Required
: constant Boolean :=
4665 Requires_Cleanup_Actions
(N
, True)
4666 or else Is_Asynchronous_Call
4668 or else Is_Protected_Subp_Body
4669 or else Is_Task_Allocation
4670 or else Is_Task_Body
4671 or else Needs_Sec_Stack_Mark
4672 or else Needs_Custom_Cleanup
;
4674 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
4678 procedure Wrap_HSS_In_Block
;
4679 -- Move HSS inside a new block along with the original exception
4680 -- handlers. Make the newly generated block the sole statement of HSS.
4682 -----------------------
4683 -- Wrap_HSS_In_Block --
4684 -----------------------
4686 procedure Wrap_HSS_In_Block
is
4688 Block_Id
: Entity_Id
;
4692 -- Preserve end label to provide proper cross-reference information
4694 End_Lab
:= End_Label
(HSS
);
4696 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
4698 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4699 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
4700 Set_Etype
(Block_Id
, Standard_Void_Type
);
4701 Set_Block_Node
(Block_Id
, Identifier
(Block
));
4703 -- Signal the finalization machinery that this particular block
4704 -- contains the original context.
4706 Set_Is_Finalization_Wrapper
(Block
);
4708 Set_Handled_Statement_Sequence
(N
,
4709 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
4710 HSS
:= Handled_Statement_Sequence
(N
);
4712 Set_First_Real_Statement
(HSS
, Block
);
4713 Set_End_Label
(HSS
, End_Lab
);
4715 -- Comment needed here, see RH for 1.306 ???
4717 if Nkind
(N
) = N_Subprogram_Body
then
4718 Set_Has_Nested_Block_With_Handler
(Scop
);
4720 end Wrap_HSS_In_Block
;
4722 -- Start of processing for Expand_Cleanup_Actions
4725 -- The current construct does not need any form of servicing
4727 if not Actions_Required
then
4730 -- If the current node is a rewritten task body and the descriptors have
4731 -- not been delayed (due to some nested instantiations), do not generate
4732 -- redundant cleanup actions.
4735 and then Nkind
(N
) = N_Subprogram_Body
4736 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4741 -- If an extended return statement contains something like
4745 -- where F is a build-in-place function call returning a controlled
4746 -- type, then a temporary object will be implicitly declared as part
4747 -- of the statement list, and this will need cleanup. In such cases,
4750 -- return Result : T := ... do
4751 -- <statements> -- possibly with handlers
4756 -- return Result : T := ... do
4757 -- declare -- no declarations
4759 -- <statements> -- possibly with handlers
4760 -- end; -- no handlers
4763 -- So Expand_Cleanup_Actions will end up being called recursively on the
4766 if Nkind
(N
) = N_Extended_Return_Statement
then
4768 Block
: constant Node_Id
:=
4769 Make_Block_Statement
(Sloc
(N
),
4770 Declarations
=> Empty_List
,
4771 Handled_Statement_Sequence
=>
4772 Handled_Statement_Sequence
(N
));
4774 Set_Handled_Statement_Sequence
(N
,
4775 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
4776 Statements
=> New_List
(Block
)));
4781 -- Analysis of the block did all the work
4786 if Needs_Custom_Cleanup
then
4787 Cln
:= Cleanup_Actions
(N
);
4793 Decls
: List_Id
:= Declarations
(N
);
4795 Mark
: Entity_Id
:= Empty
;
4796 New_Decls
: List_Id
;
4800 -- If we are generating expanded code for debugging purposes, use the
4801 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4802 -- be updated subsequently to reference the proper line in .dg files.
4803 -- If we are not debugging generated code, use No_Location instead,
4804 -- so that no debug information is generated for the cleanup code.
4805 -- This makes the behavior of the NEXT command in GDB monotonic, and
4806 -- makes the placement of breakpoints more accurate.
4808 if Debug_Generated_Code
then
4814 -- Set polling off. The finalization and cleanup code is executed
4815 -- with aborts deferred.
4817 Old_Poll
:= Polling_Required
;
4818 Polling_Required
:= False;
4820 -- A task activation call has already been built for a task
4821 -- allocation block.
4823 if not Is_Task_Allocation
then
4824 Build_Task_Activation_Call
(N
);
4828 Establish_Task_Master
(N
);
4831 New_Decls
:= New_List
;
4833 -- If secondary stack is in use, generate:
4835 -- Mnn : constant Mark_Id := SS_Mark;
4837 if Needs_Sec_Stack_Mark
then
4838 Mark
:= Make_Temporary
(Loc
, 'M');
4840 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4841 Set_Uses_Sec_Stack
(Scop
, False);
4844 -- If exception handlers are present, wrap the sequence of statements
4845 -- in a block since it is not possible to have exception handlers and
4846 -- an At_End handler in the same construct.
4848 if Present
(Exception_Handlers
(HSS
)) then
4851 -- Ensure that the First_Real_Statement field is set
4853 elsif No
(First_Real_Statement
(HSS
)) then
4854 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4857 -- Do not move the Activation_Chain declaration in the context of
4858 -- task allocation blocks. Task allocation blocks use _chain in their
4859 -- cleanup handlers and gigi complains if it is declared in the
4860 -- sequence of statements of the scope that declares the handler.
4862 if Is_Task_Allocation
then
4864 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4868 Decl
:= First
(Decls
);
4869 while Nkind
(Decl
) /= N_Object_Declaration
4870 or else Defining_Identifier
(Decl
) /= Chain
4874 -- A task allocation block should always include a _chain
4877 pragma Assert
(Present
(Decl
));
4881 Prepend_To
(New_Decls
, Decl
);
4885 -- Ensure the presence of a declaration list in order to successfully
4886 -- append all original statements to it.
4889 Set_Declarations
(N
, New_List
);
4890 Decls
:= Declarations
(N
);
4893 -- Move the declarations into the sequence of statements in order to
4894 -- have them protected by the At_End handler. It may seem weird to
4895 -- put declarations in the sequence of statement but in fact nothing
4896 -- forbids that at the tree level.
4898 Append_List_To
(Decls
, Statements
(HSS
));
4899 Set_Statements
(HSS
, Decls
);
4901 -- Reset the Sloc of the handled statement sequence to properly
4902 -- reflect the new initial "statement" in the sequence.
4904 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4906 -- The declarations of finalizer spec and auxiliary variables replace
4907 -- the old declarations that have been moved inward.
4909 Set_Declarations
(N
, New_Decls
);
4910 Analyze_Declarations
(New_Decls
);
4912 -- Generate finalization calls for all controlled objects appearing
4913 -- in the statements of N. Add context specific cleanup for various
4918 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4920 Top_Decls
=> New_Decls
,
4921 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4925 if Present
(Fin_Id
) then
4926 Build_Finalizer_Call
(N
, Fin_Id
);
4929 -- Restore saved polling mode
4931 Polling_Required
:= Old_Poll
;
4933 end Expand_Cleanup_Actions
;
4935 ---------------------------
4936 -- Expand_N_Package_Body --
4937 ---------------------------
4939 -- Add call to Activate_Tasks if body is an activator (actual processing
4940 -- is in chapter 9).
4942 -- Generate subprogram descriptor for elaboration routine
4944 -- Encode entity names in package body
4946 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4947 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
4951 -- This is done only for non-generic packages
4953 if Ekind
(Spec_Id
) = E_Package
then
4954 Push_Scope
(Spec_Id
);
4956 -- Build dispatch tables of library level tagged types
4958 if Tagged_Type_Expansion
4959 and then Is_Library_Level_Entity
(Spec_Id
)
4961 Build_Static_Dispatch_Tables
(N
);
4964 Build_Task_Activation_Call
(N
);
4966 -- Verify the run-time semantics of pragma Initial_Condition at the
4967 -- end of the body statements.
4969 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
4970 Check_Unnesting_Elaboration_Code
(N
);
4971 Check_Unnesting_In_Declarations
(N
);
4976 Set_Elaboration_Flag
(N
, Spec_Id
);
4977 Set_In_Package_Body
(Spec_Id
, False);
4979 -- Set to encode entity names in package body before gigi is called
4981 Qualify_Entity_Names
(N
);
4983 if Ekind
(Spec_Id
) /= E_Generic_Package
then
4986 Clean_Stmts
=> No_List
,
4988 Top_Decls
=> No_List
,
4989 Defer_Abort
=> False,
4992 if Present
(Fin_Id
) then
4994 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4997 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4998 Body_Ent
:= Defining_Identifier
(Body_Ent
);
5001 Set_Finalizer
(Body_Ent
, Fin_Id
);
5005 end Expand_N_Package_Body
;
5007 ----------------------------------
5008 -- Expand_N_Package_Declaration --
5009 ----------------------------------
5011 -- Add call to Activate_Tasks if there are tasks declared and the package
5012 -- has no body. Note that in Ada 83 this may result in premature activation
5013 -- of some tasks, given that we cannot tell whether a body will eventually
5016 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5017 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5018 Spec
: constant Node_Id
:= Specification
(N
);
5022 No_Body
: Boolean := False;
5023 -- True in the case of a package declaration that is a compilation
5024 -- unit and for which no associated body will be compiled in this
5028 -- Case of a package declaration other than a compilation unit
5030 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5033 -- Case of a compilation unit that does not require a body
5035 elsif not Body_Required
(Parent
(N
))
5036 and then not Unit_Requires_Body
(Id
)
5040 -- Special case of generating calling stubs for a remote call interface
5041 -- package: even though the package declaration requires one, the body
5042 -- won't be processed in this compilation (so any stubs for RACWs
5043 -- declared in the package must be generated here, along with the spec).
5045 elsif Parent
(N
) = Cunit
(Main_Unit
)
5046 and then Is_Remote_Call_Interface
(Id
)
5047 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5052 -- For a nested instance, delay processing until freeze point
5054 if Has_Delayed_Freeze
(Id
)
5055 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5060 -- For a package declaration that implies no associated body, generate
5061 -- task activation call and RACW supporting bodies now (since we won't
5062 -- have a specific separate compilation unit for that).
5067 -- Generate RACW subprogram bodies
5069 if Has_RACW
(Id
) then
5070 Decls
:= Private_Declarations
(Spec
);
5073 Decls
:= Visible_Declarations
(Spec
);
5078 Set_Visible_Declarations
(Spec
, Decls
);
5081 Append_RACW_Bodies
(Decls
, Id
);
5082 Analyze_List
(Decls
);
5085 -- Generate task activation call as last step of elaboration
5087 if Present
(Activation_Chain_Entity
(N
)) then
5088 Build_Task_Activation_Call
(N
);
5091 -- Verify the run-time semantics of pragma Initial_Condition at the
5092 -- end of the private declarations when the package lacks a body.
5094 Expand_Pragma_Initial_Condition
(Id
, N
);
5099 -- Build dispatch tables of library level tagged types
5101 if Tagged_Type_Expansion
5102 and then (Is_Compilation_Unit
(Id
)
5103 or else (Is_Generic_Instance
(Id
)
5104 and then Is_Library_Level_Entity
(Id
)))
5106 Build_Static_Dispatch_Tables
(N
);
5109 -- Note: it is not necessary to worry about generating a subprogram
5110 -- descriptor, since the only way to get exception handlers into a
5111 -- package spec is to include instantiations, and that would cause
5112 -- generation of subprogram descriptors to be delayed in any case.
5114 -- Set to encode entity names in package spec before gigi is called
5116 Qualify_Entity_Names
(N
);
5118 if Ekind
(Id
) /= E_Generic_Package
then
5121 Clean_Stmts
=> No_List
,
5123 Top_Decls
=> No_List
,
5124 Defer_Abort
=> False,
5127 Set_Finalizer
(Id
, Fin_Id
);
5129 end Expand_N_Package_Declaration
;
5131 ----------------------------
5132 -- Find_Transient_Context --
5133 ----------------------------
5135 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
5142 while Present
(Curr
) loop
5143 case Nkind
(Curr
) is
5147 -- Declarations act as a boundary for a transient scope even if
5148 -- they are not wrapped, see Wrap_Transient_Declaration.
5150 when N_Object_Declaration
5151 | N_Object_Renaming_Declaration
5152 | N_Subtype_Declaration
5158 -- Statements and statement-like constructs act as a boundary for
5159 -- a transient scope.
5161 when N_Accept_Alternative
5162 | N_Attribute_Definition_Clause
5164 | N_Case_Statement_Alternative
5166 | N_Delay_Alternative
5167 | N_Delay_Until_Statement
5168 | N_Delay_Relative_Statement
5169 | N_Discriminant_Association
5171 | N_Entry_Body_Formal_Part
5174 | N_Iteration_Scheme
5175 | N_Terminate_Alternative
5177 pragma Assert
(Present
(Prev
));
5180 when N_Assignment_Statement
=>
5183 when N_Entry_Call_Statement
5184 | N_Procedure_Call_Statement
5186 -- When an entry or procedure call acts as the alternative of a
5187 -- conditional or timed entry call, the proper context is that
5188 -- of the alternative.
5190 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
5191 and then Nkind_In
(Parent
(Parent
(Curr
)),
5192 N_Conditional_Entry_Call
,
5195 return Parent
(Parent
(Curr
));
5197 -- General case for entry or procedure calls
5205 -- Pragma Check is not a valid transient context in GNATprove
5206 -- mode because the pragma must remain unchanged.
5209 and then Get_Pragma_Id
(Curr
) = Pragma_Check
5213 -- General case for pragmas
5219 when N_Raise_Statement
=>
5222 when N_Simple_Return_Statement
=>
5224 -- A return statement is not a valid transient context when the
5225 -- function itself requires transient scope management because
5226 -- the result will be reclaimed too early.
5228 if Requires_Transient_Scope
(Etype
5229 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
5233 -- General case for return statements
5241 when N_Attribute_Reference
=>
5242 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
5246 -- An Ada 2012 iterator specification is not a valid context
5247 -- because Analyze_Iterator_Specification already employs special
5248 -- processing for it.
5250 when N_Iterator_Specification
=>
5253 when N_Loop_Parameter_Specification
=>
5255 -- An iteration scheme is not a valid context because routine
5256 -- Analyze_Iteration_Scheme already employs special processing.
5258 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
5261 return Parent
(Curr
);
5266 -- The following nodes represent "dummy contexts" which do not
5267 -- need to be wrapped.
5269 when N_Component_Declaration
5270 | N_Discriminant_Specification
5271 | N_Parameter_Specification
5275 -- If the traversal leaves a scope without having been able to
5276 -- find a construct to wrap, something is going wrong, but this
5277 -- can happen in error situations that are not detected yet (such
5278 -- as a dynamic string in a pragma Export).
5280 when N_Block_Statement
5283 | N_Package_Declaration
5297 Curr
:= Parent
(Curr
);
5301 end Find_Transient_Context
;
5303 ----------------------------------
5304 -- Has_New_Controlled_Component --
5305 ----------------------------------
5307 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
5311 if not Is_Tagged_Type
(E
) then
5312 return Has_Controlled_Component
(E
);
5313 elsif not Is_Derived_Type
(E
) then
5314 return Has_Controlled_Component
(E
);
5317 Comp
:= First_Component
(E
);
5318 while Present
(Comp
) loop
5319 if Chars
(Comp
) = Name_uParent
then
5322 elsif Scope
(Original_Record_Component
(Comp
)) = E
5323 and then Needs_Finalization
(Etype
(Comp
))
5328 Next_Component
(Comp
);
5332 end Has_New_Controlled_Component
;
5334 ---------------------------------
5335 -- Has_Simple_Protected_Object --
5336 ---------------------------------
5338 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5340 if Has_Task
(T
) then
5343 elsif Is_Simple_Protected_Type
(T
) then
5346 elsif Is_Array_Type
(T
) then
5347 return Has_Simple_Protected_Object
(Component_Type
(T
));
5349 elsif Is_Record_Type
(T
) then
5354 Comp
:= First_Component
(T
);
5355 while Present
(Comp
) loop
5356 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5360 Next_Component
(Comp
);
5369 end Has_Simple_Protected_Object
;
5371 ------------------------------------
5372 -- Insert_Actions_In_Scope_Around --
5373 ------------------------------------
5375 procedure Insert_Actions_In_Scope_Around
5378 Manage_SS
: Boolean)
5380 Act_Before
: constant List_Id
:=
5381 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5382 Act_After
: constant List_Id
:=
5383 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5384 Act_Cleanup
: constant List_Id
:=
5385 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5386 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5387 -- Last), but this was incorrect as Process_Transients_In_Scope may
5388 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5390 procedure Process_Transients_In_Scope
5391 (First_Object
: Node_Id
;
5392 Last_Object
: Node_Id
;
5393 Related_Node
: Node_Id
);
5394 -- Find all transient objects in the list First_Object .. Last_Object
5395 -- and generate finalization actions for them. Related_Node denotes the
5396 -- node which created all transient objects.
5398 ---------------------------------
5399 -- Process_Transients_In_Scope --
5400 ---------------------------------
5402 procedure Process_Transients_In_Scope
5403 (First_Object
: Node_Id
;
5404 Last_Object
: Node_Id
;
5405 Related_Node
: Node_Id
)
5407 Must_Hook
: Boolean := False;
5408 -- Flag denoting whether the context requires transient object
5409 -- export to the outer finalizer.
5411 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5412 -- Determine whether an arbitrary node denotes a subprogram call
5414 procedure Detect_Subprogram_Call
is
5415 new Traverse_Proc
(Is_Subprogram_Call
);
5417 procedure Process_Transient_In_Scope
5418 (Obj_Decl
: Node_Id
;
5419 Blk_Data
: Finalization_Exception_Data
;
5420 Blk_Stmts
: List_Id
);
5421 -- Generate finalization actions for a single transient object
5422 -- denoted by object declaration Obj_Decl. Blk_Data is the
5423 -- exception data of the enclosing block. Blk_Stmts denotes the
5424 -- statements of the enclosing block.
5426 ------------------------
5427 -- Is_Subprogram_Call --
5428 ------------------------
5430 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5432 -- A regular procedure or function call
5434 if Nkind
(N
) in N_Subprogram_Call
then
5440 -- Heavy expansion may relocate function calls outside the related
5441 -- node. Inspect the original node to detect the initial placement
5444 elsif Is_Rewrite_Substitution
(N
) then
5445 Detect_Subprogram_Call
(Original_Node
(N
));
5453 -- Generalized indexing always involves a function call
5455 elsif Nkind
(N
) = N_Indexed_Component
5456 and then Present
(Generalized_Indexing
(N
))
5466 end Is_Subprogram_Call
;
5468 --------------------------------
5469 -- Process_Transient_In_Scope --
5470 --------------------------------
5472 procedure Process_Transient_In_Scope
5473 (Obj_Decl
: Node_Id
;
5474 Blk_Data
: Finalization_Exception_Data
;
5475 Blk_Stmts
: List_Id
)
5477 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5478 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5480 Fin_Stmts
: List_Id
;
5481 Hook_Assign
: Node_Id
;
5482 Hook_Clear
: Node_Id
;
5483 Hook_Decl
: Node_Id
;
5484 Hook_Insert
: Node_Id
;
5488 -- Mark the transient object as successfully processed to avoid
5489 -- double finalization.
5491 Set_Is_Finalized_Transient
(Obj_Id
);
5493 -- Construct all the pieces necessary to hook and finalize the
5494 -- transient object.
5496 Build_Transient_Object_Statements
5497 (Obj_Decl
=> Obj_Decl
,
5498 Fin_Call
=> Fin_Call
,
5499 Hook_Assign
=> Hook_Assign
,
5500 Hook_Clear
=> Hook_Clear
,
5501 Hook_Decl
=> Hook_Decl
,
5502 Ptr_Decl
=> Ptr_Decl
);
5504 -- The context contains at least one subprogram call which may
5505 -- raise an exception. This scenario employs "hooking" to pass
5506 -- transient objects to the enclosing finalizer in case of an
5511 -- Add the access type which provides a reference to the
5512 -- transient object. Generate:
5514 -- type Ptr_Typ is access all Desig_Typ;
5516 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5518 -- Add the temporary which acts as a hook to the transient
5519 -- object. Generate:
5521 -- Hook : Ptr_Typ := null;
5523 Insert_Action
(Obj_Decl
, Hook_Decl
);
5525 -- When the transient object is initialized by an aggregate,
5526 -- the hook must capture the object after the last aggregate
5527 -- assignment takes place. Only then is the object considered
5528 -- fully initialized. Generate:
5530 -- Hook := Ptr_Typ (Obj_Id);
5532 -- Hook := Obj_Id'Unrestricted_Access;
5534 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
5535 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
5537 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5539 -- Otherwise the hook seizes the related object immediately
5542 Hook_Insert
:= Obj_Decl
;
5545 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5548 -- When exception propagation is enabled wrap the hook clear
5549 -- statement and the finalization call into a block to catch
5550 -- potential exceptions raised during finalization. Generate:
5554 -- [Deep_]Finalize (Obj_Ref);
5558 -- if not Raised then
5561 -- (Enn, Get_Current_Excep.all.all);
5565 if Exceptions_OK
then
5566 Fin_Stmts
:= New_List
;
5569 Append_To
(Fin_Stmts
, Hook_Clear
);
5572 Append_To
(Fin_Stmts
, Fin_Call
);
5574 Prepend_To
(Blk_Stmts
,
5575 Make_Block_Statement
(Loc
,
5576 Handled_Statement_Sequence
=>
5577 Make_Handled_Sequence_Of_Statements
(Loc
,
5578 Statements
=> Fin_Stmts
,
5579 Exception_Handlers
=> New_List
(
5580 Build_Exception_Handler
(Blk_Data
)))));
5582 -- Otherwise generate:
5585 -- [Deep_]Finalize (Obj_Ref);
5587 -- Note that the statements are inserted in reverse order to
5588 -- achieve the desired final order outlined above.
5591 Prepend_To
(Blk_Stmts
, Fin_Call
);
5594 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5597 end Process_Transient_In_Scope
;
5601 Built
: Boolean := False;
5602 Blk_Data
: Finalization_Exception_Data
;
5603 Blk_Decl
: Node_Id
:= Empty
;
5604 Blk_Decls
: List_Id
:= No_List
;
5606 Blk_Stmts
: List_Id
;
5610 -- Start of processing for Process_Transients_In_Scope
5613 -- The expansion performed by this routine is as follows:
5615 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5616 -- Hook_1 : Ptr_Typ_1 := null;
5617 -- Ctrl_Trans_Obj_1 : ...;
5618 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5620 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5621 -- Hook_N : Ptr_Typ_N := null;
5622 -- Ctrl_Trans_Obj_N : ...;
5623 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5626 -- Abrt : constant Boolean := ...;
5627 -- Ex : Exception_Occurrence;
5628 -- Raised : Boolean := False;
5635 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5639 -- if not Raised then
5641 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5646 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5650 -- if not Raised then
5652 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5657 -- if Raised and not Abrt then
5658 -- Raise_From_Controlled_Operation (Ex);
5662 -- Recognize a scenario where the transient context is an object
5663 -- declaration initialized by a build-in-place function call:
5665 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5667 -- The rough expansion of the above is:
5669 -- Temp : ... := Ctrl_Func_Call;
5671 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5673 -- The finalization of any transient object must happen after the
5674 -- build-in-place function call is executed.
5676 if Nkind
(N
) = N_Object_Declaration
5677 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5680 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5682 -- Search the context for at least one subprogram call. If found, the
5683 -- machinery exports all transient objects to the enclosing finalizer
5684 -- due to the possibility of abnormal call termination.
5687 Detect_Subprogram_Call
(N
);
5688 Blk_Ins
:= Last_Object
;
5692 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5695 -- Examine all objects in the list First_Object .. Last_Object
5697 Obj_Decl
:= First_Object
;
5698 while Present
(Obj_Decl
) loop
5699 if Nkind
(Obj_Decl
) = N_Object_Declaration
5700 and then Analyzed
(Obj_Decl
)
5701 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5703 -- Do not process the node to be wrapped since it will be
5704 -- handled by the enclosing finalizer.
5706 and then Obj_Decl
/= Related_Node
5708 Loc
:= Sloc
(Obj_Decl
);
5710 -- Before generating the cleanup code for the first transient
5711 -- object, create a wrapper block which houses all hook clear
5712 -- statements and finalization calls. This wrapper is needed by
5717 Blk_Stmts
:= New_List
;
5720 -- Abrt : constant Boolean := ...;
5721 -- Ex : Exception_Occurrence;
5722 -- Raised : Boolean := False;
5724 if Exceptions_OK
then
5725 Blk_Decls
:= New_List
;
5726 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5730 Make_Block_Statement
(Loc
,
5731 Declarations
=> Blk_Decls
,
5732 Handled_Statement_Sequence
=>
5733 Make_Handled_Sequence_Of_Statements
(Loc
,
5734 Statements
=> Blk_Stmts
));
5737 -- Construct all necessary circuitry to hook and finalize a
5738 -- single transient object.
5740 Process_Transient_In_Scope
5741 (Obj_Decl
=> Obj_Decl
,
5742 Blk_Data
=> Blk_Data
,
5743 Blk_Stmts
=> Blk_Stmts
);
5746 -- Terminate the scan after the last object has been processed to
5747 -- avoid touching unrelated code.
5749 if Obj_Decl
= Last_Object
then
5756 -- Complete the decoration of the enclosing finalization block and
5757 -- insert it into the tree.
5759 if Present
(Blk_Decl
) then
5761 -- Note that this Abort_Undefer does not require a extra block or
5762 -- an AT_END handler because each finalization exception is caught
5763 -- in its own corresponding finalization block. As a result, the
5764 -- call to Abort_Defer always takes place.
5766 if Abort_Allowed
then
5767 Prepend_To
(Blk_Stmts
,
5768 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5770 Append_To
(Blk_Stmts
,
5771 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5775 -- if Raised and then not Abrt then
5776 -- Raise_From_Controlled_Operation (Ex);
5779 if Exceptions_OK
then
5780 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5783 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5785 end Process_Transients_In_Scope
;
5789 Loc
: constant Source_Ptr
:= Sloc
(N
);
5790 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5791 First_Obj
: Node_Id
;
5793 Mark_Id
: Entity_Id
;
5796 -- Start of processing for Insert_Actions_In_Scope_Around
5799 -- Nothing to do if the scope does not manage the secondary stack or
5800 -- does not contain meaninful actions for insertion.
5803 and then No
(Act_Before
)
5804 and then No
(Act_After
)
5805 and then No
(Act_Cleanup
)
5810 -- If the node to be wrapped is the trigger of an asynchronous select,
5811 -- it is not part of a statement list. The actions must be inserted
5812 -- before the select itself, which is part of some list of statements.
5813 -- Note that the triggering alternative includes the triggering
5814 -- statement and an optional statement list. If the node to be
5815 -- wrapped is part of that list, the normal insertion applies.
5817 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5818 and then not Is_List_Member
(Node_To_Wrap
)
5820 Target
:= Parent
(Parent
(Node_To_Wrap
));
5825 First_Obj
:= Target
;
5828 -- Add all actions associated with a transient scope into the main tree.
5829 -- There are several scenarios here:
5831 -- +--- Before ----+ +----- After ---+
5832 -- 1) First_Obj ....... Target ........ Last_Obj
5834 -- 2) First_Obj ....... Target
5836 -- 3) Target ........ Last_Obj
5838 -- Flag declarations are inserted before the first object
5840 if Present
(Act_Before
) then
5841 First_Obj
:= First
(Act_Before
);
5842 Insert_List_Before
(Target
, Act_Before
);
5845 -- Finalization calls are inserted after the last object
5847 if Present
(Act_After
) then
5848 Last_Obj
:= Last
(Act_After
);
5849 Insert_List_After
(Target
, Act_After
);
5852 -- Mark and release the secondary stack when the context warrants it
5855 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5858 -- Mnn : constant Mark_Id := SS_Mark;
5860 Insert_Before_And_Analyze
5861 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5864 -- SS_Release (Mnn);
5866 Insert_After_And_Analyze
5867 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5870 -- Check for transient objects associated with Target and generate the
5871 -- appropriate finalization actions for them.
5873 Process_Transients_In_Scope
5874 (First_Object
=> First_Obj
,
5875 Last_Object
=> Last_Obj
,
5876 Related_Node
=> Target
);
5878 -- Reset the action lists
5881 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5883 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5887 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5889 end Insert_Actions_In_Scope_Around
;
5891 ------------------------------
5892 -- Is_Simple_Protected_Type --
5893 ------------------------------
5895 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5898 Is_Protected_Type
(T
)
5899 and then not Uses_Lock_Free
(T
)
5900 and then not Has_Entries
(T
)
5901 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5902 end Is_Simple_Protected_Type
;
5904 -----------------------
5905 -- Make_Adjust_Call --
5906 -----------------------
5908 function Make_Adjust_Call
5911 Skip_Self
: Boolean := False) return Node_Id
5913 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5914 Adj_Id
: Entity_Id
:= Empty
;
5921 -- Recover the proper type which contains Deep_Adjust
5923 if Is_Class_Wide_Type
(Typ
) then
5924 Utyp
:= Root_Type
(Typ
);
5929 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5930 Set_Assignment_OK
(Ref
);
5932 -- Deal with untagged derivation of private views
5934 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5935 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5936 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5937 Set_Assignment_OK
(Ref
);
5940 -- When dealing with the completion of a private type, use the base
5943 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5944 pragma Assert
(Is_Private_Type
(Typ
));
5946 Utyp
:= Base_Type
(Utyp
);
5947 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5950 -- The underlying type may not be present due to a missing full view. In
5951 -- this case freezing did not take place and there is no [Deep_]Adjust
5952 -- primitive to call.
5957 elsif Skip_Self
then
5958 if Has_Controlled_Component
(Utyp
) then
5959 if Is_Tagged_Type
(Utyp
) then
5960 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5962 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5966 -- Class-wide types, interfaces and types with controlled components
5968 elsif Is_Class_Wide_Type
(Typ
)
5969 or else Is_Interface
(Typ
)
5970 or else Has_Controlled_Component
(Utyp
)
5972 if Is_Tagged_Type
(Utyp
) then
5973 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5975 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5978 -- Derivations from [Limited_]Controlled
5980 elsif Is_Controlled
(Utyp
) then
5981 if Has_Controlled_Component
(Utyp
) then
5982 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5984 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5989 elsif Is_Tagged_Type
(Utyp
) then
5990 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5993 raise Program_Error
;
5996 if Present
(Adj_Id
) then
5998 -- If the object is unanalyzed, set its expected type for use in
5999 -- Convert_View in case an additional conversion is needed.
6002 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
6004 Set_Etype
(Ref
, Typ
);
6007 -- The object reference may need another conversion depending on the
6008 -- type of the formal and that of the actual.
6010 if not Is_Class_Wide_Type
(Typ
) then
6011 Ref
:= Convert_View
(Adj_Id
, Ref
);
6018 Skip_Self
=> Skip_Self
);
6022 end Make_Adjust_Call
;
6024 ----------------------
6025 -- Make_Detach_Call --
6026 ----------------------
6028 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
6029 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
6033 Make_Procedure_Call_Statement
(Loc
,
6035 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
6036 Parameter_Associations
=> New_List
(
6037 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
6038 end Make_Detach_Call
;
6046 Proc_Id
: Entity_Id
;
6048 Skip_Self
: Boolean := False) return Node_Id
6050 Params
: constant List_Id
:= New_List
(Param
);
6053 -- Do not apply the controlled action to the object itself by signaling
6054 -- the related routine to avoid self.
6057 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6061 Make_Procedure_Call_Statement
(Loc
,
6062 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6063 Parameter_Associations
=> Params
);
6066 --------------------------
6067 -- Make_Deep_Array_Body --
6068 --------------------------
6070 function Make_Deep_Array_Body
6071 (Prim
: Final_Primitives
;
6072 Typ
: Entity_Id
) return List_Id
6074 function Build_Adjust_Or_Finalize_Statements
6075 (Typ
: Entity_Id
) return List_Id
;
6076 -- Create the statements necessary to adjust or finalize an array of
6077 -- controlled elements. Generate:
6080 -- Abort : constant Boolean := Triggered_By_Abort;
6082 -- Abort : constant Boolean := False; -- no abort
6084 -- E : Exception_Occurrence;
6085 -- Raised : Boolean := False;
6088 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6089 -- ^-- in the finalization case
6091 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6093 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6097 -- if not Raised then
6099 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6106 -- if Raised and then not Abort then
6107 -- Raise_From_Controlled_Operation (E);
6111 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6112 -- Create the statements necessary to initialize an array of controlled
6113 -- elements. Include a mechanism to carry out partial finalization if an
6114 -- exception occurs. Generate:
6117 -- Counter : Integer := 0;
6120 -- for J1 in V'Range (1) loop
6122 -- for JN in V'Range (N) loop
6124 -- [Deep_]Initialize (V (J1, ..., JN));
6126 -- Counter := Counter + 1;
6131 -- Abort : constant Boolean := Triggered_By_Abort;
6133 -- Abort : constant Boolean := False; -- no abort
6134 -- E : Exception_Occurrence;
6135 -- Raised : Boolean := False;
6142 -- V'Length (N) - Counter;
6144 -- for F1 in reverse V'Range (1) loop
6146 -- for FN in reverse V'Range (N) loop
6147 -- if Counter > 0 then
6148 -- Counter := Counter - 1;
6151 -- [Deep_]Finalize (V (F1, ..., FN));
6155 -- if not Raised then
6157 -- Save_Occurrence (E,
6158 -- Get_Current_Excep.all.all);
6167 -- if Raised and then not Abort then
6168 -- Raise_From_Controlled_Operation (E);
6177 function New_References_To
6179 Loc
: Source_Ptr
) return List_Id
;
6180 -- Given a list of defining identifiers, return a list of references to
6181 -- the original identifiers, in the same order as they appear.
6183 -----------------------------------------
6184 -- Build_Adjust_Or_Finalize_Statements --
6185 -----------------------------------------
6187 function Build_Adjust_Or_Finalize_Statements
6188 (Typ
: Entity_Id
) return List_Id
6190 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6191 Index_List
: constant List_Id
:= New_List
;
6192 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6193 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6195 procedure Build_Indexes
;
6196 -- Generate the indexes used in the dimension loops
6202 procedure Build_Indexes
is
6204 -- Generate the following identifiers:
6205 -- Jnn - for initialization
6207 for Dim
in 1 .. Num_Dims
loop
6208 Append_To
(Index_List
,
6209 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6215 Final_Decls
: List_Id
:= No_List
;
6216 Final_Data
: Finalization_Exception_Data
;
6220 Core_Loop
: Node_Id
;
6223 Loop_Id
: Entity_Id
;
6226 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6229 Final_Decls
:= New_List
;
6232 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6235 Make_Indexed_Component
(Loc
,
6236 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6237 Expressions
=> New_References_To
(Index_List
, Loc
));
6238 Set_Etype
(Comp_Ref
, Comp_Typ
);
6241 -- [Deep_]Adjust (V (J1, ..., JN))
6243 if Prim
= Adjust_Case
then
6244 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6247 -- [Deep_]Finalize (V (J1, ..., JN))
6249 else pragma Assert
(Prim
= Finalize_Case
);
6250 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6253 if Present
(Call
) then
6255 -- Generate the block which houses the adjust or finalize call:
6258 -- <adjust or finalize call>
6262 -- if not Raised then
6264 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6268 if Exceptions_OK
then
6270 Make_Block_Statement
(Loc
,
6271 Handled_Statement_Sequence
=>
6272 Make_Handled_Sequence_Of_Statements
(Loc
,
6273 Statements
=> New_List
(Call
),
6274 Exception_Handlers
=> New_List
(
6275 Build_Exception_Handler
(Final_Data
))));
6280 -- Generate the dimension loops starting from the innermost one
6282 -- for Jnn in [reverse] V'Range (Dim) loop
6286 J
:= Last
(Index_List
);
6288 while Present
(J
) and then Dim
> 0 loop
6294 Make_Loop_Statement
(Loc
,
6296 Make_Iteration_Scheme
(Loc
,
6297 Loop_Parameter_Specification
=>
6298 Make_Loop_Parameter_Specification
(Loc
,
6299 Defining_Identifier
=> Loop_Id
,
6300 Discrete_Subtype_Definition
=>
6301 Make_Attribute_Reference
(Loc
,
6302 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6303 Attribute_Name
=> Name_Range
,
6304 Expressions
=> New_List
(
6305 Make_Integer_Literal
(Loc
, Dim
))),
6308 Prim
= Finalize_Case
)),
6310 Statements
=> New_List
(Core_Loop
),
6311 End_Label
=> Empty
);
6316 -- Generate the block which contains the core loop, declarations
6317 -- of the abort flag, the exception occurrence, the raised flag
6318 -- and the conditional raise:
6321 -- Abort : constant Boolean := Triggered_By_Abort;
6323 -- Abort : constant Boolean := False; -- no abort
6325 -- E : Exception_Occurrence;
6326 -- Raised : Boolean := False;
6331 -- if Raised and then not Abort then
6332 -- Raise_From_Controlled_Operation (E);
6336 Stmts
:= New_List
(Core_Loop
);
6338 if Exceptions_OK
then
6339 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6343 Make_Block_Statement
(Loc
,
6344 Declarations
=> Final_Decls
,
6345 Handled_Statement_Sequence
=>
6346 Make_Handled_Sequence_Of_Statements
(Loc
,
6347 Statements
=> Stmts
));
6349 -- Otherwise previous errors or a missing full view may prevent the
6350 -- proper freezing of the component type. If this is the case, there
6351 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6354 Block
:= Make_Null_Statement
(Loc
);
6357 return New_List
(Block
);
6358 end Build_Adjust_Or_Finalize_Statements
;
6360 ---------------------------------
6361 -- Build_Initialize_Statements --
6362 ---------------------------------
6364 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6365 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6366 Final_List
: constant List_Id
:= New_List
;
6367 Index_List
: constant List_Id
:= New_List
;
6368 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6369 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6371 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6372 -- Generate the following assignment:
6373 -- Counter := V'Length (1) *
6375 -- V'Length (N) - Counter;
6377 -- Counter_Id denotes the entity of the counter.
6379 function Build_Finalization_Call
return Node_Id
;
6380 -- Generate a deep finalization call for an array element
6382 procedure Build_Indexes
;
6383 -- Generate the initialization and finalization indexes used in the
6386 function Build_Initialization_Call
return Node_Id
;
6387 -- Generate a deep initialization call for an array element
6389 ----------------------
6390 -- Build_Assignment --
6391 ----------------------
6393 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6398 -- Start from the first dimension and generate:
6403 Make_Attribute_Reference
(Loc
,
6404 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6405 Attribute_Name
=> Name_Length
,
6406 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6408 -- Process the rest of the dimensions, generate:
6409 -- Expr * V'Length (N)
6412 while Dim
<= Num_Dims
loop
6414 Make_Op_Multiply
(Loc
,
6417 Make_Attribute_Reference
(Loc
,
6418 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6419 Attribute_Name
=> Name_Length
,
6420 Expressions
=> New_List
(
6421 Make_Integer_Literal
(Loc
, Dim
))));
6427 -- Counter := Expr - Counter;
6430 Make_Assignment_Statement
(Loc
,
6431 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6433 Make_Op_Subtract
(Loc
,
6435 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6436 end Build_Assignment
;
6438 -----------------------------
6439 -- Build_Finalization_Call --
6440 -----------------------------
6442 function Build_Finalization_Call
return Node_Id
is
6443 Comp_Ref
: constant Node_Id
:=
6444 Make_Indexed_Component
(Loc
,
6445 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6446 Expressions
=> New_References_To
(Final_List
, Loc
));
6449 Set_Etype
(Comp_Ref
, Comp_Typ
);
6452 -- [Deep_]Finalize (V);
6454 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6455 end Build_Finalization_Call
;
6461 procedure Build_Indexes
is
6463 -- Generate the following identifiers:
6464 -- Jnn - for initialization
6465 -- Fnn - for finalization
6467 for Dim
in 1 .. Num_Dims
loop
6468 Append_To
(Index_List
,
6469 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6471 Append_To
(Final_List
,
6472 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6476 -------------------------------
6477 -- Build_Initialization_Call --
6478 -------------------------------
6480 function Build_Initialization_Call
return Node_Id
is
6481 Comp_Ref
: constant Node_Id
:=
6482 Make_Indexed_Component
(Loc
,
6483 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6484 Expressions
=> New_References_To
(Index_List
, Loc
));
6487 Set_Etype
(Comp_Ref
, Comp_Typ
);
6490 -- [Deep_]Initialize (V (J1, ..., JN));
6492 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6493 end Build_Initialization_Call
;
6497 Counter_Id
: Entity_Id
;
6501 Final_Block
: Node_Id
;
6502 Final_Data
: Finalization_Exception_Data
;
6503 Final_Decls
: List_Id
:= No_List
;
6504 Final_Loop
: Node_Id
;
6505 Init_Block
: Node_Id
;
6506 Init_Call
: Node_Id
;
6507 Init_Loop
: Node_Id
;
6512 -- Start of processing for Build_Initialize_Statements
6515 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6516 Final_Decls
:= New_List
;
6519 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6521 -- Generate the block which houses the finalization call, the index
6522 -- guard and the handler which triggers Program_Error later on.
6524 -- if Counter > 0 then
6525 -- Counter := Counter - 1;
6528 -- [Deep_]Finalize (V (F1, ..., FN));
6531 -- if not Raised then
6533 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6538 Fin_Stmt
:= Build_Finalization_Call
;
6540 if Present
(Fin_Stmt
) then
6541 if Exceptions_OK
then
6543 Make_Block_Statement
(Loc
,
6544 Handled_Statement_Sequence
=>
6545 Make_Handled_Sequence_Of_Statements
(Loc
,
6546 Statements
=> New_List
(Fin_Stmt
),
6547 Exception_Handlers
=> New_List
(
6548 Build_Exception_Handler
(Final_Data
))));
6551 -- This is the core of the loop, the dimension iterators are added
6552 -- one by one in reverse.
6555 Make_If_Statement
(Loc
,
6558 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6559 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6561 Then_Statements
=> New_List
(
6562 Make_Assignment_Statement
(Loc
,
6563 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6565 Make_Op_Subtract
(Loc
,
6566 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6567 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6569 Else_Statements
=> New_List
(Fin_Stmt
));
6571 -- Generate all finalization loops starting from the innermost
6574 -- for Fnn in reverse V'Range (Dim) loop
6578 F
:= Last
(Final_List
);
6580 while Present
(F
) and then Dim
> 0 loop
6586 Make_Loop_Statement
(Loc
,
6588 Make_Iteration_Scheme
(Loc
,
6589 Loop_Parameter_Specification
=>
6590 Make_Loop_Parameter_Specification
(Loc
,
6591 Defining_Identifier
=> Loop_Id
,
6592 Discrete_Subtype_Definition
=>
6593 Make_Attribute_Reference
(Loc
,
6594 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6595 Attribute_Name
=> Name_Range
,
6596 Expressions
=> New_List
(
6597 Make_Integer_Literal
(Loc
, Dim
))),
6599 Reverse_Present
=> True)),
6601 Statements
=> New_List
(Final_Loop
),
6602 End_Label
=> Empty
);
6607 -- Generate the block which contains the finalization loops, the
6608 -- declarations of the abort flag, the exception occurrence, the
6609 -- raised flag and the conditional raise.
6612 -- Abort : constant Boolean := Triggered_By_Abort;
6614 -- Abort : constant Boolean := False; -- no abort
6616 -- E : Exception_Occurrence;
6617 -- Raised : Boolean := False;
6623 -- V'Length (N) - Counter;
6627 -- if Raised and then not Abort then
6628 -- Raise_From_Controlled_Operation (E);
6634 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6636 if Exceptions_OK
then
6637 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6638 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6642 Make_Block_Statement
(Loc
,
6643 Declarations
=> Final_Decls
,
6644 Handled_Statement_Sequence
=>
6645 Make_Handled_Sequence_Of_Statements
(Loc
,
6646 Statements
=> Stmts
));
6648 -- Otherwise previous errors or a missing full view may prevent the
6649 -- proper freezing of the component type. If this is the case, there
6650 -- is no [Deep_]Finalize primitive to call.
6653 Final_Block
:= Make_Null_Statement
(Loc
);
6656 -- Generate the block which contains the initialization call and
6657 -- the partial finalization code.
6660 -- [Deep_]Initialize (V (J1, ..., JN));
6662 -- Counter := Counter + 1;
6666 -- <finalization code>
6669 Init_Call
:= Build_Initialization_Call
;
6671 -- Only create finalization block if there is a non-trivial
6672 -- call to initialization.
6674 if Present
(Init_Call
)
6675 and then Nkind
(Init_Call
) /= N_Null_Statement
6678 Make_Block_Statement
(Loc
,
6679 Handled_Statement_Sequence
=>
6680 Make_Handled_Sequence_Of_Statements
(Loc
,
6681 Statements
=> New_List
(Init_Call
),
6682 Exception_Handlers
=> New_List
(
6683 Make_Exception_Handler
(Loc
,
6684 Exception_Choices
=> New_List
(
6685 Make_Others_Choice
(Loc
)),
6686 Statements
=> New_List
(Final_Block
)))));
6688 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6689 Make_Assignment_Statement
(Loc
,
6690 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6693 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6694 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6696 -- Generate all initialization loops starting from the innermost
6699 -- for Jnn in V'Range (Dim) loop
6703 J
:= Last
(Index_List
);
6705 while Present
(J
) and then Dim
> 0 loop
6711 Make_Loop_Statement
(Loc
,
6713 Make_Iteration_Scheme
(Loc
,
6714 Loop_Parameter_Specification
=>
6715 Make_Loop_Parameter_Specification
(Loc
,
6716 Defining_Identifier
=> Loop_Id
,
6717 Discrete_Subtype_Definition
=>
6718 Make_Attribute_Reference
(Loc
,
6719 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6720 Attribute_Name
=> Name_Range
,
6721 Expressions
=> New_List
(
6722 Make_Integer_Literal
(Loc
, Dim
))))),
6724 Statements
=> New_List
(Init_Loop
),
6725 End_Label
=> Empty
);
6730 -- Generate the block which contains the counter variable and the
6731 -- initialization loops.
6734 -- Counter : Integer := 0;
6740 Make_Block_Statement
(Loc
,
6741 Declarations
=> New_List
(
6742 Make_Object_Declaration
(Loc
,
6743 Defining_Identifier
=> Counter_Id
,
6744 Object_Definition
=>
6745 New_Occurrence_Of
(Standard_Integer
, Loc
),
6746 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6748 Handled_Statement_Sequence
=>
6749 Make_Handled_Sequence_Of_Statements
(Loc
,
6750 Statements
=> New_List
(Init_Loop
)));
6752 -- Otherwise previous errors or a missing full view may prevent the
6753 -- proper freezing of the component type. If this is the case, there
6754 -- is no [Deep_]Initialize primitive to call.
6757 Init_Block
:= Make_Null_Statement
(Loc
);
6760 return New_List
(Init_Block
);
6761 end Build_Initialize_Statements
;
6763 -----------------------
6764 -- New_References_To --
6765 -----------------------
6767 function New_References_To
6769 Loc
: Source_Ptr
) return List_Id
6771 Refs
: constant List_Id
:= New_List
;
6776 while Present
(Id
) loop
6777 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6782 end New_References_To
;
6784 -- Start of processing for Make_Deep_Array_Body
6788 when Address_Case
=>
6789 return Make_Finalize_Address_Stmts
(Typ
);
6794 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6796 when Initialize_Case
=>
6797 return Build_Initialize_Statements
(Typ
);
6799 end Make_Deep_Array_Body
;
6801 --------------------
6802 -- Make_Deep_Proc --
6803 --------------------
6805 function Make_Deep_Proc
6806 (Prim
: Final_Primitives
;
6808 Stmts
: List_Id
) return Entity_Id
6810 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6812 Proc_Id
: Entity_Id
;
6815 -- Create the object formal, generate:
6816 -- V : System.Address
6818 if Prim
= Address_Case
then
6819 Formals
:= New_List
(
6820 Make_Parameter_Specification
(Loc
,
6821 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6823 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6830 Formals
:= New_List
(
6831 Make_Parameter_Specification
(Loc
,
6832 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6834 Out_Present
=> True,
6835 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6837 -- F : Boolean := True
6839 if Prim
= Adjust_Case
6840 or else Prim
= Finalize_Case
6843 Make_Parameter_Specification
(Loc
,
6844 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6846 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6848 New_Occurrence_Of
(Standard_True
, Loc
)));
6853 Make_Defining_Identifier
(Loc
,
6854 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6857 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6860 -- exception -- Finalize and Adjust cases only
6861 -- raise Program_Error;
6862 -- end Deep_Initialize / Adjust / Finalize;
6866 -- procedure Finalize_Address (V : System.Address) is
6869 -- end Finalize_Address;
6872 Make_Subprogram_Body
(Loc
,
6874 Make_Procedure_Specification
(Loc
,
6875 Defining_Unit_Name
=> Proc_Id
,
6876 Parameter_Specifications
=> Formals
),
6878 Declarations
=> Empty_List
,
6880 Handled_Statement_Sequence
=>
6881 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6883 -- If there are no calls to component initialization, indicate that
6884 -- the procedure is trivial, so prevent calls to it.
6886 if Is_Empty_List
(Stmts
)
6887 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6889 Set_Is_Trivial_Subprogram
(Proc_Id
);
6895 ---------------------------
6896 -- Make_Deep_Record_Body --
6897 ---------------------------
6899 function Make_Deep_Record_Body
6900 (Prim
: Final_Primitives
;
6902 Is_Local
: Boolean := False) return List_Id
6904 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6905 -- Build the statements necessary to adjust a record type. The type may
6906 -- have discriminants and contain variant parts. Generate:
6910 -- [Deep_]Adjust (V.Comp_1);
6912 -- when Id : others =>
6913 -- if not Raised then
6915 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6920 -- [Deep_]Adjust (V.Comp_N);
6922 -- when Id : others =>
6923 -- if not Raised then
6925 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6930 -- Deep_Adjust (V._parent, False); -- If applicable
6932 -- when Id : others =>
6933 -- if not Raised then
6935 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6941 -- Adjust (V); -- If applicable
6944 -- if not Raised then
6946 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6951 -- if Raised and then not Abort then
6952 -- Raise_From_Controlled_Operation (E);
6956 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6957 -- Build the statements necessary to finalize a record type. The type
6958 -- may have discriminants and contain variant parts. Generate:
6961 -- Abort : constant Boolean := Triggered_By_Abort;
6963 -- Abort : constant Boolean := False; -- no abort
6964 -- E : Exception_Occurrence;
6965 -- Raised : Boolean := False;
6970 -- Finalize (V); -- If applicable
6973 -- if not Raised then
6975 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6980 -- case Variant_1 is
6982 -- case State_Counter_N => -- If Is_Local is enabled
6992 -- <<LN>> -- If Is_Local is enabled
6994 -- [Deep_]Finalize (V.Comp_N);
6997 -- if not Raised then
6999 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7005 -- [Deep_]Finalize (V.Comp_1);
7008 -- if not Raised then
7010 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7016 -- case State_Counter_1 => -- If Is_Local is enabled
7022 -- Deep_Finalize (V._parent, False); -- If applicable
7024 -- when Id : others =>
7025 -- if not Raised then
7027 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7031 -- if Raised and then not Abort then
7032 -- Raise_From_Controlled_Operation (E);
7036 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7037 -- Given a derived tagged type Typ, traverse all components, find field
7038 -- _parent and return its type.
7040 procedure Preprocess_Components
7042 Num_Comps
: out Nat
;
7043 Has_POC
: out Boolean);
7044 -- Examine all components in component list Comps, count all controlled
7045 -- components and determine whether at least one of them is per-object
7046 -- constrained. Component _parent is always skipped.
7048 -----------------------------
7049 -- Build_Adjust_Statements --
7050 -----------------------------
7052 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7053 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7054 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7056 Finalizer_Data
: Finalization_Exception_Data
;
7058 function Process_Component_List_For_Adjust
7059 (Comps
: Node_Id
) return List_Id
;
7060 -- Build all necessary adjust statements for a single component list
7062 ---------------------------------------
7063 -- Process_Component_List_For_Adjust --
7064 ---------------------------------------
7066 function Process_Component_List_For_Adjust
7067 (Comps
: Node_Id
) return List_Id
7069 Stmts
: constant List_Id
:= New_List
;
7071 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7072 -- Process the declaration of a single controlled component
7074 ----------------------------------
7075 -- Process_Component_For_Adjust --
7076 ----------------------------------
7078 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7079 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7080 Typ
: constant Entity_Id
:= Etype
(Id
);
7086 -- [Deep_]Adjust (V.Id);
7090 -- if not Raised then
7092 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7099 Make_Selected_Component
(Loc
,
7100 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7101 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7104 -- Guard against a missing [Deep_]Adjust when the component
7105 -- type was not properly frozen.
7107 if Present
(Adj_Call
) then
7108 if Exceptions_OK
then
7110 Make_Block_Statement
(Loc
,
7111 Handled_Statement_Sequence
=>
7112 Make_Handled_Sequence_Of_Statements
(Loc
,
7113 Statements
=> New_List
(Adj_Call
),
7114 Exception_Handlers
=> New_List
(
7115 Build_Exception_Handler
(Finalizer_Data
))));
7118 Append_To
(Stmts
, Adj_Call
);
7120 end Process_Component_For_Adjust
;
7125 Decl_Id
: Entity_Id
;
7126 Decl_Typ
: Entity_Id
;
7131 -- Start of processing for Process_Component_List_For_Adjust
7134 -- Perform an initial check, determine the number of controlled
7135 -- components in the current list and whether at least one of them
7136 -- is per-object constrained.
7138 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7140 -- The processing in this routine is done in the following order:
7141 -- 1) Regular components
7142 -- 2) Per-object constrained components
7145 if Num_Comps
> 0 then
7147 -- Process all regular components in order of declarations
7149 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7150 while Present
(Decl
) loop
7151 Decl_Id
:= Defining_Identifier
(Decl
);
7152 Decl_Typ
:= Etype
(Decl_Id
);
7154 -- Skip _parent as well as per-object constrained components
7156 if Chars
(Decl_Id
) /= Name_uParent
7157 and then Needs_Finalization
(Decl_Typ
)
7159 if Has_Access_Constraint
(Decl_Id
)
7160 and then No
(Expression
(Decl
))
7164 Process_Component_For_Adjust
(Decl
);
7168 Next_Non_Pragma
(Decl
);
7171 -- Process all per-object constrained components in order of
7175 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7176 while Present
(Decl
) loop
7177 Decl_Id
:= Defining_Identifier
(Decl
);
7178 Decl_Typ
:= Etype
(Decl_Id
);
7182 if Chars
(Decl_Id
) /= Name_uParent
7183 and then Needs_Finalization
(Decl_Typ
)
7184 and then Has_Access_Constraint
(Decl_Id
)
7185 and then No
(Expression
(Decl
))
7187 Process_Component_For_Adjust
(Decl
);
7190 Next_Non_Pragma
(Decl
);
7195 -- Process all variants, if any
7198 if Present
(Variant_Part
(Comps
)) then
7200 Var_Alts
: constant List_Id
:= New_List
;
7204 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7205 while Present
(Var
) loop
7208 -- when <discrete choices> =>
7209 -- <adjust statements>
7211 Append_To
(Var_Alts
,
7212 Make_Case_Statement_Alternative
(Loc
,
7214 New_Copy_List
(Discrete_Choices
(Var
)),
7216 Process_Component_List_For_Adjust
(
7217 Component_List
(Var
))));
7219 Next_Non_Pragma
(Var
);
7223 -- case V.<discriminant> is
7224 -- when <discrete choices 1> =>
7225 -- <adjust statements 1>
7227 -- when <discrete choices N> =>
7228 -- <adjust statements N>
7232 Make_Case_Statement
(Loc
,
7234 Make_Selected_Component
(Loc
,
7235 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7237 Make_Identifier
(Loc
,
7238 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7239 Alternatives
=> Var_Alts
);
7243 -- Add the variant case statement to the list of statements
7245 if Present
(Var_Case
) then
7246 Append_To
(Stmts
, Var_Case
);
7249 -- If the component list did not have any controlled components
7250 -- nor variants, return null.
7252 if Is_Empty_List
(Stmts
) then
7253 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7257 end Process_Component_List_For_Adjust
;
7261 Bod_Stmts
: List_Id
:= No_List
;
7262 Finalizer_Decls
: List_Id
:= No_List
;
7265 -- Start of processing for Build_Adjust_Statements
7268 Finalizer_Decls
:= New_List
;
7269 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7271 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7272 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7277 -- Create an adjust sequence for all record components
7279 if Present
(Component_List
(Rec_Def
)) then
7281 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7284 -- A derived record type must adjust all inherited components. This
7285 -- action poses the following problem:
7287 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7292 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7294 -- Deep_Adjust (Obj._parent);
7299 -- Adjusting the derived type will invoke Adjust of the parent and
7300 -- then that of the derived type. This is undesirable because both
7301 -- routines may modify shared components. Only the Adjust of the
7302 -- derived type should be invoked.
7304 -- To prevent this double adjustment of shared components,
7305 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7307 -- procedure Deep_Adjust
7308 -- (Obj : in out Some_Type;
7309 -- Flag : Boolean := True)
7317 -- When Deep_Adjust is invokes for field _parent, a value of False is
7318 -- provided for the flag:
7320 -- Deep_Adjust (Obj._parent, False);
7322 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7324 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7329 if Needs_Finalization
(Par_Typ
) then
7333 Make_Selected_Component
(Loc
,
7334 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7336 Make_Identifier
(Loc
, Name_uParent
)),
7342 -- Deep_Adjust (V._parent, False);
7345 -- when Id : others =>
7346 -- if not Raised then
7348 -- Save_Occurrence (E,
7349 -- Get_Current_Excep.all.all);
7353 if Present
(Call
) then
7356 if Exceptions_OK
then
7358 Make_Block_Statement
(Loc
,
7359 Handled_Statement_Sequence
=>
7360 Make_Handled_Sequence_Of_Statements
(Loc
,
7361 Statements
=> New_List
(Adj_Stmt
),
7362 Exception_Handlers
=> New_List
(
7363 Build_Exception_Handler
(Finalizer_Data
))));
7366 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7372 -- Adjust the object. This action must be performed last after all
7373 -- components have been adjusted.
7375 if Is_Controlled
(Typ
) then
7381 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7390 -- if not Raised then
7392 -- Save_Occurrence (E,
7393 -- Get_Current_Excep.all.all);
7398 if Present
(Proc
) then
7400 Make_Procedure_Call_Statement
(Loc
,
7401 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7402 Parameter_Associations
=> New_List
(
7403 Make_Identifier
(Loc
, Name_V
)));
7405 if Exceptions_OK
then
7407 Make_Block_Statement
(Loc
,
7408 Handled_Statement_Sequence
=>
7409 Make_Handled_Sequence_Of_Statements
(Loc
,
7410 Statements
=> New_List
(Adj_Stmt
),
7411 Exception_Handlers
=> New_List
(
7412 Build_Exception_Handler
7413 (Finalizer_Data
))));
7416 Append_To
(Bod_Stmts
,
7417 Make_If_Statement
(Loc
,
7418 Condition
=> Make_Identifier
(Loc
, Name_F
),
7419 Then_Statements
=> New_List
(Adj_Stmt
)));
7424 -- At this point either all adjustment statements have been generated
7425 -- or the type is not controlled.
7427 if Is_Empty_List
(Bod_Stmts
) then
7428 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7434 -- Abort : constant Boolean := Triggered_By_Abort;
7436 -- Abort : constant Boolean := False; -- no abort
7438 -- E : Exception_Occurrence;
7439 -- Raised : Boolean := False;
7442 -- <adjust statements>
7444 -- if Raised and then not Abort then
7445 -- Raise_From_Controlled_Operation (E);
7450 if Exceptions_OK
then
7451 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7456 Make_Block_Statement
(Loc
,
7459 Handled_Statement_Sequence
=>
7460 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7462 end Build_Adjust_Statements
;
7464 -------------------------------
7465 -- Build_Finalize_Statements --
7466 -------------------------------
7468 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7469 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7470 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7473 Finalizer_Data
: Finalization_Exception_Data
;
7475 function Process_Component_List_For_Finalize
7476 (Comps
: Node_Id
) return List_Id
;
7477 -- Build all necessary finalization statements for a single component
7478 -- list. The statements may include a jump circuitry if flag Is_Local
7481 -----------------------------------------
7482 -- Process_Component_List_For_Finalize --
7483 -----------------------------------------
7485 function Process_Component_List_For_Finalize
7486 (Comps
: Node_Id
) return List_Id
7488 procedure Process_Component_For_Finalize
7493 Num_Comps
: in out Nat
);
7494 -- Process the declaration of a single controlled component. If
7495 -- flag Is_Local is enabled, create the corresponding label and
7496 -- jump circuitry. Alts is the list of case alternatives, Decls
7497 -- is the top level declaration list where labels are declared
7498 -- and Stmts is the list of finalization actions. Num_Comps
7499 -- denotes the current number of components needing finalization.
7501 ------------------------------------
7502 -- Process_Component_For_Finalize --
7503 ------------------------------------
7505 procedure Process_Component_For_Finalize
7510 Num_Comps
: in out Nat
)
7512 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7513 Typ
: constant Entity_Id
:= Etype
(Id
);
7520 Label_Id
: Entity_Id
;
7527 Make_Identifier
(Loc
,
7528 Chars
=> New_External_Name
('L', Num_Comps
));
7529 Set_Entity
(Label_Id
,
7530 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7531 Label
:= Make_Label
(Loc
, Label_Id
);
7534 Make_Implicit_Label_Declaration
(Loc
,
7535 Defining_Identifier
=> Entity
(Label_Id
),
7536 Label_Construct
=> Label
));
7543 Make_Case_Statement_Alternative
(Loc
,
7544 Discrete_Choices
=> New_List
(
7545 Make_Integer_Literal
(Loc
, Num_Comps
)),
7547 Statements
=> New_List
(
7548 Make_Goto_Statement
(Loc
,
7550 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7555 Append_To
(Stmts
, Label
);
7557 -- Decrease the number of components to be processed.
7558 -- This action yields a new Label_Id in future calls.
7560 Num_Comps
:= Num_Comps
- 1;
7565 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7567 -- begin -- Exception handlers allowed
7568 -- [Deep_]Finalize (V.Id);
7571 -- if not Raised then
7573 -- Save_Occurrence (E,
7574 -- Get_Current_Excep.all.all);
7581 Make_Selected_Component
(Loc
,
7582 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7583 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7586 -- Guard against a missing [Deep_]Finalize when the component
7587 -- type was not properly frozen.
7589 if Present
(Fin_Call
) then
7590 if Exceptions_OK
then
7592 Make_Block_Statement
(Loc
,
7593 Handled_Statement_Sequence
=>
7594 Make_Handled_Sequence_Of_Statements
(Loc
,
7595 Statements
=> New_List
(Fin_Call
),
7596 Exception_Handlers
=> New_List
(
7597 Build_Exception_Handler
(Finalizer_Data
))));
7600 Append_To
(Stmts
, Fin_Call
);
7602 end Process_Component_For_Finalize
;
7607 Counter_Id
: Entity_Id
:= Empty
;
7609 Decl_Id
: Entity_Id
;
7610 Decl_Typ
: Entity_Id
;
7613 Jump_Block
: Node_Id
;
7615 Label_Id
: Entity_Id
;
7620 -- Start of processing for Process_Component_List_For_Finalize
7623 -- Perform an initial check, look for controlled and per-object
7624 -- constrained components.
7626 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7628 -- Create a state counter to service the current component list.
7629 -- This step is performed before the variants are inspected in
7630 -- order to generate the same state counter names as those from
7631 -- Build_Initialize_Statements.
7633 if Num_Comps
> 0 and then Is_Local
then
7634 Counter
:= Counter
+ 1;
7637 Make_Defining_Identifier
(Loc
,
7638 Chars
=> New_External_Name
('C', Counter
));
7641 -- Process the component in the following order:
7643 -- 2) Per-object constrained components
7644 -- 3) Regular components
7646 -- Start with the variant parts
7649 if Present
(Variant_Part
(Comps
)) then
7651 Var_Alts
: constant List_Id
:= New_List
;
7655 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7656 while Present
(Var
) loop
7659 -- when <discrete choices> =>
7660 -- <finalize statements>
7662 Append_To
(Var_Alts
,
7663 Make_Case_Statement_Alternative
(Loc
,
7665 New_Copy_List
(Discrete_Choices
(Var
)),
7667 Process_Component_List_For_Finalize
(
7668 Component_List
(Var
))));
7670 Next_Non_Pragma
(Var
);
7674 -- case V.<discriminant> is
7675 -- when <discrete choices 1> =>
7676 -- <finalize statements 1>
7678 -- when <discrete choices N> =>
7679 -- <finalize statements N>
7683 Make_Case_Statement
(Loc
,
7685 Make_Selected_Component
(Loc
,
7686 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7688 Make_Identifier
(Loc
,
7689 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7690 Alternatives
=> Var_Alts
);
7694 -- The current component list does not have a single controlled
7695 -- component, however it may contain variants. Return the case
7696 -- statement for the variants or nothing.
7698 if Num_Comps
= 0 then
7699 if Present
(Var_Case
) then
7700 return New_List
(Var_Case
);
7702 return New_List
(Make_Null_Statement
(Loc
));
7706 -- Prepare all lists
7712 -- Process all per-object constrained components in reverse order
7715 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7716 while Present
(Decl
) loop
7717 Decl_Id
:= Defining_Identifier
(Decl
);
7718 Decl_Typ
:= Etype
(Decl_Id
);
7722 if Chars
(Decl_Id
) /= Name_uParent
7723 and then Needs_Finalization
(Decl_Typ
)
7724 and then Has_Access_Constraint
(Decl_Id
)
7725 and then No
(Expression
(Decl
))
7727 Process_Component_For_Finalize
7728 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7731 Prev_Non_Pragma
(Decl
);
7735 -- Process the rest of the components in reverse order
7737 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7738 while Present
(Decl
) loop
7739 Decl_Id
:= Defining_Identifier
(Decl
);
7740 Decl_Typ
:= Etype
(Decl_Id
);
7744 if Chars
(Decl_Id
) /= Name_uParent
7745 and then Needs_Finalization
(Decl_Typ
)
7747 -- Skip per-object constrained components since they were
7748 -- handled in the above step.
7750 if Has_Access_Constraint
(Decl_Id
)
7751 and then No
(Expression
(Decl
))
7755 Process_Component_For_Finalize
7756 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7760 Prev_Non_Pragma
(Decl
);
7765 -- LN : label; -- If Is_Local is enabled
7770 -- case CounterX is .
7780 -- <<LN>> -- If Is_Local is enabled
7782 -- [Deep_]Finalize (V.CompY);
7784 -- when Id : others =>
7785 -- if not Raised then
7787 -- Save_Occurrence (E,
7788 -- Get_Current_Excep.all.all);
7792 -- <<L0>> -- If Is_Local is enabled
7797 -- Add the declaration of default jump location L0, its
7798 -- corresponding alternative and its place in the statements.
7800 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7801 Set_Entity
(Label_Id
,
7802 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7803 Label
:= Make_Label
(Loc
, Label_Id
);
7805 Append_To
(Decls
, -- declaration
7806 Make_Implicit_Label_Declaration
(Loc
,
7807 Defining_Identifier
=> Entity
(Label_Id
),
7808 Label_Construct
=> Label
));
7810 Append_To
(Alts
, -- alternative
7811 Make_Case_Statement_Alternative
(Loc
,
7812 Discrete_Choices
=> New_List
(
7813 Make_Others_Choice
(Loc
)),
7815 Statements
=> New_List
(
7816 Make_Goto_Statement
(Loc
,
7817 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7819 Append_To
(Stmts
, Label
); -- statement
7821 -- Create the jump block
7824 Make_Case_Statement
(Loc
,
7825 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7826 Alternatives
=> Alts
));
7830 Make_Block_Statement
(Loc
,
7831 Declarations
=> Decls
,
7832 Handled_Statement_Sequence
=>
7833 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7835 if Present
(Var_Case
) then
7836 return New_List
(Var_Case
, Jump_Block
);
7838 return New_List
(Jump_Block
);
7840 end Process_Component_List_For_Finalize
;
7844 Bod_Stmts
: List_Id
:= No_List
;
7845 Finalizer_Decls
: List_Id
:= No_List
;
7848 -- Start of processing for Build_Finalize_Statements
7851 Finalizer_Decls
:= New_List
;
7852 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7854 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7855 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7860 -- Create a finalization sequence for all record components
7862 if Present
(Component_List
(Rec_Def
)) then
7864 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7867 -- A derived record type must finalize all inherited components. This
7868 -- action poses the following problem:
7870 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7875 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7877 -- Deep_Finalize (Obj._parent);
7882 -- Finalizing the derived type will invoke Finalize of the parent and
7883 -- then that of the derived type. This is undesirable because both
7884 -- routines may modify shared components. Only the Finalize of the
7885 -- derived type should be invoked.
7887 -- To prevent this double adjustment of shared components,
7888 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7890 -- procedure Deep_Finalize
7891 -- (Obj : in out Some_Type;
7892 -- Flag : Boolean := True)
7900 -- When Deep_Finalize is invoked for field _parent, a value of False
7901 -- is provided for the flag:
7903 -- Deep_Finalize (Obj._parent, False);
7905 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7907 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7912 if Needs_Finalization
(Par_Typ
) then
7916 Make_Selected_Component
(Loc
,
7917 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7919 Make_Identifier
(Loc
, Name_uParent
)),
7925 -- Deep_Finalize (V._parent, False);
7928 -- when Id : others =>
7929 -- if not Raised then
7931 -- Save_Occurrence (E,
7932 -- Get_Current_Excep.all.all);
7936 if Present
(Call
) then
7939 if Exceptions_OK
then
7941 Make_Block_Statement
(Loc
,
7942 Handled_Statement_Sequence
=>
7943 Make_Handled_Sequence_Of_Statements
(Loc
,
7944 Statements
=> New_List
(Fin_Stmt
),
7945 Exception_Handlers
=> New_List
(
7946 Build_Exception_Handler
7947 (Finalizer_Data
))));
7950 Append_To
(Bod_Stmts
, Fin_Stmt
);
7956 -- Finalize the object. This action must be performed first before
7957 -- all components have been finalized.
7959 if Is_Controlled
(Typ
) and then not Is_Local
then
7965 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7974 -- if not Raised then
7976 -- Save_Occurrence (E,
7977 -- Get_Current_Excep.all.all);
7982 if Present
(Proc
) then
7984 Make_Procedure_Call_Statement
(Loc
,
7985 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7986 Parameter_Associations
=> New_List
(
7987 Make_Identifier
(Loc
, Name_V
)));
7989 if Exceptions_OK
then
7991 Make_Block_Statement
(Loc
,
7992 Handled_Statement_Sequence
=>
7993 Make_Handled_Sequence_Of_Statements
(Loc
,
7994 Statements
=> New_List
(Fin_Stmt
),
7995 Exception_Handlers
=> New_List
(
7996 Build_Exception_Handler
7997 (Finalizer_Data
))));
8000 Prepend_To
(Bod_Stmts
,
8001 Make_If_Statement
(Loc
,
8002 Condition
=> Make_Identifier
(Loc
, Name_F
),
8003 Then_Statements
=> New_List
(Fin_Stmt
)));
8008 -- At this point either all finalization statements have been
8009 -- generated or the type is not controlled.
8011 if No
(Bod_Stmts
) then
8012 return New_List
(Make_Null_Statement
(Loc
));
8016 -- Abort : constant Boolean := Triggered_By_Abort;
8018 -- Abort : constant Boolean := False; -- no abort
8020 -- E : Exception_Occurrence;
8021 -- Raised : Boolean := False;
8024 -- <finalize statements>
8026 -- if Raised and then not Abort then
8027 -- Raise_From_Controlled_Operation (E);
8032 if Exceptions_OK
then
8033 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8038 Make_Block_Statement
(Loc
,
8041 Handled_Statement_Sequence
=>
8042 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8044 end Build_Finalize_Statements
;
8046 -----------------------
8047 -- Parent_Field_Type --
8048 -----------------------
8050 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8054 Field
:= First_Entity
(Typ
);
8055 while Present
(Field
) loop
8056 if Chars
(Field
) = Name_uParent
then
8057 return Etype
(Field
);
8060 Next_Entity
(Field
);
8063 -- A derived tagged type should always have a parent field
8065 raise Program_Error
;
8066 end Parent_Field_Type
;
8068 ---------------------------
8069 -- Preprocess_Components --
8070 ---------------------------
8072 procedure Preprocess_Components
8074 Num_Comps
: out Nat
;
8075 Has_POC
: out Boolean)
8085 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8086 while Present
(Decl
) loop
8087 Id
:= Defining_Identifier
(Decl
);
8090 -- Skip field _parent
8092 if Chars
(Id
) /= Name_uParent
8093 and then Needs_Finalization
(Typ
)
8095 Num_Comps
:= Num_Comps
+ 1;
8097 if Has_Access_Constraint
(Id
)
8098 and then No
(Expression
(Decl
))
8104 Next_Non_Pragma
(Decl
);
8106 end Preprocess_Components
;
8108 -- Start of processing for Make_Deep_Record_Body
8112 when Address_Case
=>
8113 return Make_Finalize_Address_Stmts
(Typ
);
8116 return Build_Adjust_Statements
(Typ
);
8118 when Finalize_Case
=>
8119 return Build_Finalize_Statements
(Typ
);
8121 when Initialize_Case
=>
8123 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8126 if Is_Controlled
(Typ
) then
8128 Make_Procedure_Call_Statement
(Loc
,
8131 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8132 Parameter_Associations
=> New_List
(
8133 Make_Identifier
(Loc
, Name_V
))));
8139 end Make_Deep_Record_Body
;
8141 ----------------------
8142 -- Make_Final_Call --
8143 ----------------------
8145 function Make_Final_Call
8148 Skip_Self
: Boolean := False) return Node_Id
8150 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8152 Fin_Id
: Entity_Id
:= Empty
;
8159 -- Recover the proper type which contains [Deep_]Finalize
8161 if Is_Class_Wide_Type
(Typ
) then
8162 Utyp
:= Root_Type
(Typ
);
8165 elsif Is_Concurrent_Type
(Typ
) then
8166 Utyp
:= Corresponding_Record_Type
(Typ
);
8168 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8170 elsif Is_Private_Type
(Typ
)
8171 and then Present
(Full_View
(Typ
))
8172 and then Is_Concurrent_Type
(Full_View
(Typ
))
8174 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
8176 Ref
:= Convert_Concurrent
(Ref
, Full_View
(Typ
));
8183 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8184 Set_Assignment_OK
(Ref
);
8186 -- Deal with untagged derivation of private views. If the parent type
8187 -- is a protected type, Deep_Finalize is found on the corresponding
8188 -- record of the ancestor.
8190 if Is_Untagged_Derivation
(Typ
) then
8191 if Is_Protected_Type
(Typ
) then
8192 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8194 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8196 if Is_Protected_Type
(Utyp
) then
8197 Utyp
:= Corresponding_Record_Type
(Utyp
);
8201 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8202 Set_Assignment_OK
(Ref
);
8205 -- Deal with derived private types which do not inherit primitives from
8206 -- their parents. In this case, [Deep_]Finalize can be found in the full
8207 -- view of the parent type.
8210 and then Is_Tagged_Type
(Utyp
)
8211 and then Is_Derived_Type
(Utyp
)
8212 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8213 and then Is_Private_Type
(Etype
(Utyp
))
8214 and then Present
(Full_View
(Etype
(Utyp
)))
8216 Utyp
:= Full_View
(Etype
(Utyp
));
8217 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8218 Set_Assignment_OK
(Ref
);
8221 -- When dealing with the completion of a private type, use the base type
8224 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8225 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8227 Utyp
:= Base_Type
(Utyp
);
8228 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8229 Set_Assignment_OK
(Ref
);
8232 -- The underlying type may not be present due to a missing full view. In
8233 -- this case freezing did not take place and there is no [Deep_]Finalize
8234 -- primitive to call.
8239 elsif Skip_Self
then
8240 if Has_Controlled_Component
(Utyp
) then
8241 if Is_Tagged_Type
(Utyp
) then
8242 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8244 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8248 -- Class-wide types, interfaces and types with controlled components
8250 elsif Is_Class_Wide_Type
(Typ
)
8251 or else Is_Interface
(Typ
)
8252 or else Has_Controlled_Component
(Utyp
)
8254 if Is_Tagged_Type
(Utyp
) then
8255 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8257 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8260 -- Derivations from [Limited_]Controlled
8262 elsif Is_Controlled
(Utyp
) then
8263 if Has_Controlled_Component
(Utyp
) then
8264 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8266 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8271 elsif Is_Tagged_Type
(Utyp
) then
8272 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8275 raise Program_Error
;
8278 if Present
(Fin_Id
) then
8280 -- When finalizing a class-wide object, do not convert to the root
8281 -- type in order to produce a dispatching call.
8283 if Is_Class_Wide_Type
(Typ
) then
8286 -- Ensure that a finalization routine is at least decorated in order
8287 -- to inspect the object parameter.
8289 elsif Analyzed
(Fin_Id
)
8290 or else Ekind
(Fin_Id
) = E_Procedure
8292 -- In certain cases, such as the creation of Stream_Read, the
8293 -- visible entity of the type is its full view. Since Stream_Read
8294 -- will have to create an object of type Typ, the local object
8295 -- will be finalzed by the scope finalizer generated later on. The
8296 -- object parameter of Deep_Finalize will always use the private
8297 -- view of the type. To avoid such a clash between a private and a
8298 -- full view, perform an unchecked conversion of the object
8299 -- reference to the private view.
8302 Formal_Typ
: constant Entity_Id
:=
8303 Etype
(First_Formal
(Fin_Id
));
8305 if Is_Private_Type
(Formal_Typ
)
8306 and then Present
(Full_View
(Formal_Typ
))
8307 and then Full_View
(Formal_Typ
) = Utyp
8309 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8313 Ref
:= Convert_View
(Fin_Id
, Ref
);
8320 Skip_Self
=> Skip_Self
);
8324 end Make_Final_Call
;
8326 --------------------------------
8327 -- Make_Finalize_Address_Body --
8328 --------------------------------
8330 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8331 Is_Task
: constant Boolean :=
8332 Ekind
(Typ
) = E_Record_Type
8333 and then Is_Concurrent_Record_Type
(Typ
)
8334 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8336 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8337 Proc_Id
: Entity_Id
;
8341 -- The corresponding records of task types are not controlled by design.
8342 -- For the sake of completeness, create an empty Finalize_Address to be
8343 -- used in task class-wide allocations.
8348 -- Nothing to do if the type is not controlled or it already has a
8349 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8350 -- come from source. These are usually generated for completeness and
8351 -- do not need the Finalize_Address primitive.
8353 elsif not Needs_Finalization
(Typ
)
8354 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8356 (Is_Class_Wide_Type
(Typ
)
8357 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8358 and then not Comes_From_Source
(Root_Type
(Typ
)))
8363 -- Do not generate Finalize_Address routine for CodePeer
8365 if CodePeer_Mode
then
8370 Make_Defining_Identifier
(Loc
,
8371 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8375 -- procedure <Typ>FD (V : System.Address) is
8377 -- null; -- for tasks
8379 -- declare -- for all other types
8380 -- type Pnn is access all Typ;
8381 -- for Pnn'Storage_Size use 0;
8383 -- [Deep_]Finalize (Pnn (V).all);
8388 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8390 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8394 Make_Subprogram_Body
(Loc
,
8396 Make_Procedure_Specification
(Loc
,
8397 Defining_Unit_Name
=> Proc_Id
,
8399 Parameter_Specifications
=> New_List
(
8400 Make_Parameter_Specification
(Loc
,
8401 Defining_Identifier
=>
8402 Make_Defining_Identifier
(Loc
, Name_V
),
8404 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8406 Declarations
=> No_List
,
8408 Handled_Statement_Sequence
=>
8409 Make_Handled_Sequence_Of_Statements
(Loc
,
8410 Statements
=> Stmts
)));
8412 Set_TSS
(Typ
, Proc_Id
);
8413 end Make_Finalize_Address_Body
;
8415 ---------------------------------
8416 -- Make_Finalize_Address_Stmts --
8417 ---------------------------------
8419 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8420 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8423 Desig_Typ
: Entity_Id
;
8424 Fin_Block
: Node_Id
;
8427 Ptr_Typ
: Entity_Id
;
8430 if Is_Array_Type
(Typ
) then
8431 if Is_Constrained
(First_Subtype
(Typ
)) then
8432 Desig_Typ
:= First_Subtype
(Typ
);
8434 Desig_Typ
:= Base_Type
(Typ
);
8437 -- Class-wide types of constrained root types
8439 elsif Is_Class_Wide_Type
(Typ
)
8440 and then Has_Discriminants
(Root_Type
(Typ
))
8442 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8445 Parent_Typ
: Entity_Id
;
8448 -- Climb the parent type chain looking for a non-constrained type
8450 Parent_Typ
:= Root_Type
(Typ
);
8451 while Parent_Typ
/= Etype
(Parent_Typ
)
8452 and then Has_Discriminants
(Parent_Typ
)
8454 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8456 Parent_Typ
:= Etype
(Parent_Typ
);
8459 -- Handle views created for tagged types with unknown
8462 if Is_Underlying_Record_View
(Parent_Typ
) then
8463 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8466 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
8476 -- type Ptr_Typ is access all Typ;
8477 -- for Ptr_Typ'Storage_Size use 0;
8479 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8482 Make_Full_Type_Declaration
(Loc
,
8483 Defining_Identifier
=> Ptr_Typ
,
8485 Make_Access_To_Object_Definition
(Loc
,
8486 All_Present
=> True,
8487 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8489 Make_Attribute_Definition_Clause
(Loc
,
8490 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8491 Chars
=> Name_Storage_Size
,
8492 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8494 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8496 -- Unconstrained arrays require special processing in order to retrieve
8497 -- the elements. To achieve this, we have to skip the dope vector which
8498 -- lays in front of the elements and then use a thin pointer to perform
8499 -- the address-to-access conversion.
8501 if Is_Array_Type
(Typ
)
8502 and then not Is_Constrained
(First_Subtype
(Typ
))
8505 Dope_Id
: Entity_Id
;
8508 -- Ensure that Ptr_Typ a thin pointer, generate:
8509 -- for Ptr_Typ'Size use System.Address'Size;
8512 Make_Attribute_Definition_Clause
(Loc
,
8513 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8516 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8519 -- Dnn : constant Storage_Offset :=
8520 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8522 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8525 Make_Object_Declaration
(Loc
,
8526 Defining_Identifier
=> Dope_Id
,
8527 Constant_Present
=> True,
8528 Object_Definition
=>
8529 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8531 Make_Op_Divide
(Loc
,
8533 Make_Attribute_Reference
(Loc
,
8534 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8535 Attribute_Name
=> Name_Descriptor_Size
),
8537 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8539 -- Shift the address from the start of the dope vector to the
8540 -- start of the elements:
8544 -- Note that this is done through a wrapper routine since RTSfind
8545 -- cannot retrieve operations with string names of the form "+".
8548 Make_Function_Call
(Loc
,
8550 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8551 Parameter_Associations
=> New_List
(
8553 New_Occurrence_Of
(Dope_Id
, Loc
)));
8560 Make_Explicit_Dereference
(Loc
,
8561 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8564 if Present
(Fin_Call
) then
8566 Make_Block_Statement
(Loc
,
8567 Declarations
=> Decls
,
8568 Handled_Statement_Sequence
=>
8569 Make_Handled_Sequence_Of_Statements
(Loc
,
8570 Statements
=> New_List
(Fin_Call
)));
8572 -- Otherwise previous errors or a missing full view may prevent the
8573 -- proper freezing of the designated type. If this is the case, there
8574 -- is no [Deep_]Finalize primitive to call.
8577 Fin_Block
:= Make_Null_Statement
(Loc
);
8580 return New_List
(Fin_Block
);
8581 end Make_Finalize_Address_Stmts
;
8583 -------------------------------------
8584 -- Make_Handler_For_Ctrl_Operation --
8585 -------------------------------------
8589 -- when E : others =>
8590 -- Raise_From_Controlled_Operation (E);
8595 -- raise Program_Error [finalize raised exception];
8597 -- depending on whether Raise_From_Controlled_Operation is available
8599 function Make_Handler_For_Ctrl_Operation
8600 (Loc
: Source_Ptr
) return Node_Id
8603 -- Choice parameter (for the first case above)
8605 Raise_Node
: Node_Id
;
8606 -- Procedure call or raise statement
8609 -- Standard run-time: add choice parameter E and pass it to
8610 -- Raise_From_Controlled_Operation so that the original exception
8611 -- name and message can be recorded in the exception message for
8614 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8615 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8617 Make_Procedure_Call_Statement
(Loc
,
8620 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8621 Parameter_Associations
=> New_List
(
8622 New_Occurrence_Of
(E_Occ
, Loc
)));
8624 -- Restricted run-time: exception messages are not supported
8629 Make_Raise_Program_Error
(Loc
,
8630 Reason
=> PE_Finalize_Raised_Exception
);
8634 Make_Implicit_Exception_Handler
(Loc
,
8635 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8636 Choice_Parameter
=> E_Occ
,
8637 Statements
=> New_List
(Raise_Node
));
8638 end Make_Handler_For_Ctrl_Operation
;
8640 --------------------
8641 -- Make_Init_Call --
8642 --------------------
8644 function Make_Init_Call
8646 Typ
: Entity_Id
) return Node_Id
8648 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8657 -- Deal with the type and object reference. Depending on the context, an
8658 -- object reference may need several conversions.
8660 if Is_Concurrent_Type
(Typ
) then
8662 Utyp
:= Corresponding_Record_Type
(Typ
);
8663 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8665 elsif Is_Private_Type
(Typ
)
8666 and then Present
(Full_View
(Typ
))
8667 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8670 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8671 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8678 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8679 Set_Assignment_OK
(Ref
);
8681 -- Deal with untagged derivation of private views
8683 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8684 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8685 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8687 -- The following is to prevent problems with UC see 1.156 RH ???
8689 Set_Assignment_OK
(Ref
);
8692 -- If the underlying_type is a subtype, then we are dealing with the
8693 -- completion of a private type. We need to access the base type and
8694 -- generate a conversion to it.
8696 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8697 pragma Assert
(Is_Private_Type
(Typ
));
8698 Utyp
:= Base_Type
(Utyp
);
8699 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8702 -- The underlying type may not be present due to a missing full view.
8703 -- In this case freezing did not take place and there is no suitable
8704 -- [Deep_]Initialize primitive to call.
8710 -- Select the appropriate version of initialize
8712 if Has_Controlled_Component
(Utyp
) then
8713 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8715 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8716 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8719 -- If initialization procedure for an array of controlled objects is
8720 -- trivial, do not generate a useless call to it.
8722 if (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8724 (not Comes_From_Source
(Proc
)
8725 and then Present
(Alias
(Proc
))
8726 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8728 return Make_Null_Statement
(Loc
);
8731 -- The object reference may need another conversion depending on the
8732 -- type of the formal and that of the actual.
8734 Ref
:= Convert_View
(Proc
, Ref
);
8737 -- [Deep_]Initialize (Ref);
8740 Make_Procedure_Call_Statement
(Loc
,
8741 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8742 Parameter_Associations
=> New_List
(Ref
));
8745 ------------------------------
8746 -- Make_Local_Deep_Finalize --
8747 ------------------------------
8749 function Make_Local_Deep_Finalize
8751 Nam
: Entity_Id
) return Node_Id
8753 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8757 Formals
:= New_List
(
8761 Make_Parameter_Specification
(Loc
,
8762 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8764 Out_Present
=> True,
8765 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8767 -- F : Boolean := True
8769 Make_Parameter_Specification
(Loc
,
8770 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8771 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8772 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8774 -- Add the necessary number of counters to represent the initialization
8775 -- state of an object.
8778 Make_Subprogram_Body
(Loc
,
8780 Make_Procedure_Specification
(Loc
,
8781 Defining_Unit_Name
=> Nam
,
8782 Parameter_Specifications
=> Formals
),
8784 Declarations
=> No_List
,
8786 Handled_Statement_Sequence
=>
8787 Make_Handled_Sequence_Of_Statements
(Loc
,
8788 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8789 end Make_Local_Deep_Finalize
;
8791 ------------------------------------
8792 -- Make_Set_Finalize_Address_Call --
8793 ------------------------------------
8795 function Make_Set_Finalize_Address_Call
8797 Ptr_Typ
: Entity_Id
) return Node_Id
8799 -- It is possible for Ptr_Typ to be a partial view, if the access type
8800 -- is a full view declared in the private part of a nested package, and
8801 -- the finalization actions take place when completing analysis of the
8802 -- enclosing unit. For this reason use Underlying_Type twice below.
8804 Desig_Typ
: constant Entity_Id
:=
8806 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8807 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8808 Fin_Mas
: constant Entity_Id
:=
8809 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8812 -- Both the finalization master and primitive Finalize_Address must be
8815 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8818 -- Set_Finalize_Address
8819 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8822 Make_Procedure_Call_Statement
(Loc
,
8824 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8825 Parameter_Associations
=> New_List
(
8826 New_Occurrence_Of
(Fin_Mas
, Loc
),
8828 Make_Attribute_Reference
(Loc
,
8829 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8830 Attribute_Name
=> Name_Unrestricted_Access
)));
8831 end Make_Set_Finalize_Address_Call
;
8833 --------------------------
8834 -- Make_Transient_Block --
8835 --------------------------
8837 function Make_Transient_Block
8840 Par
: Node_Id
) return Node_Id
8842 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8843 -- Determine whether scoping entity Id manages the secondary stack
8845 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
8846 -- Return True when N appears within a loop and no block is containing N
8848 -----------------------
8849 -- Manages_Sec_Stack --
8850 -----------------------
8852 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8856 -- An exception handler with a choice parameter utilizes a dummy
8857 -- block to provide a declarative region. Such a block should not
8858 -- be considered because it never manifests in the tree and can
8859 -- never release the secondary stack.
8863 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8870 return Uses_Sec_Stack
(Id
);
8875 end Manages_Sec_Stack
;
8877 ---------------------------
8878 -- Within_Loop_Statement --
8879 ---------------------------
8881 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
8882 Par
: Node_Id
:= Parent
(N
);
8885 while not (Nkind_In
(Par
, N_Handled_Sequence_Of_Statements
,
8887 N_Package_Specification
)
8888 or else Nkind
(Par
) in N_Proper_Body
)
8890 pragma Assert
(Present
(Par
));
8891 Par
:= Parent
(Par
);
8894 return Nkind
(Par
) = N_Loop_Statement
;
8895 end Within_Loop_Statement
;
8899 Decls
: constant List_Id
:= New_List
;
8900 Instrs
: constant List_Id
:= New_List
(Action
);
8901 Trans_Id
: constant Entity_Id
:= Current_Scope
;
8907 -- Start of processing for Make_Transient_Block
8910 -- Even though the transient block is tasked with managing the secondary
8911 -- stack, the block may forgo this functionality depending on how the
8912 -- secondary stack is managed by enclosing scopes.
8914 if Manages_Sec_Stack
(Trans_Id
) then
8916 -- Determine whether an enclosing scope already manages the secondary
8919 Scop
:= Scope
(Trans_Id
);
8920 while Present
(Scop
) loop
8922 -- It should not be possible to reach Standard without hitting one
8923 -- of the other cases first unless Standard was manually pushed.
8925 if Scop
= Standard_Standard
then
8928 -- The transient block is within a function which returns on the
8929 -- secondary stack. Take a conservative approach and assume that
8930 -- the value on the secondary stack is part of the result. Note
8931 -- that it is not possible to detect this dependency without flow
8932 -- analysis which the compiler does not have. Letting the object
8933 -- live longer than the transient block will not leak any memory
8934 -- because the caller will reclaim the total storage used by the
8937 elsif Ekind
(Scop
) = E_Function
8938 and then Sec_Stack_Needed_For_Return
(Scop
)
8940 Set_Uses_Sec_Stack
(Trans_Id
, False);
8943 -- The transient block must manage the secondary stack when the
8944 -- block appears within a loop in order to reclaim the memory at
8947 elsif Ekind
(Scop
) = E_Loop
then
8950 -- Ditto when the block appears without a block that does not
8951 -- manage the secondary stack and is located within a loop.
8953 elsif Ekind
(Scop
) = E_Block
8954 and then not Manages_Sec_Stack
(Scop
)
8955 and then Present
(Block_Node
(Scop
))
8956 and then Within_Loop_Statement
(Block_Node
(Scop
))
8960 -- The transient block does not need to manage the secondary stack
8961 -- when there is an enclosing construct which already does that.
8962 -- This optimization saves on SS_Mark and SS_Release calls but may
8963 -- allow objects to live a little longer than required.
8965 -- The transient block must manage the secondary stack when switch
8966 -- -gnatd.s (strict management) is in effect.
8968 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
8969 Set_Uses_Sec_Stack
(Trans_Id
, False);
8972 -- Prevent the search from going too far because transient blocks
8973 -- are bounded by packages and subprogram scopes.
8975 elsif Ekind_In
(Scop
, E_Entry
,
8985 Scop
:= Scope
(Scop
);
8989 -- Create the transient block. Set the parent now since the block itself
8990 -- is not part of the tree. The current scope is the E_Block entity that
8991 -- has been pushed by Establish_Transient_Scope.
8993 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
8996 Make_Block_Statement
(Loc
,
8997 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
8998 Declarations
=> Decls
,
8999 Handled_Statement_Sequence
=>
9000 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9001 Has_Created_Identifier
=> True);
9002 Set_Parent
(Block
, Par
);
9004 -- Insert actions stuck in the transient scopes as well as all freezing
9005 -- nodes needed by those actions. Do not insert cleanup actions here,
9006 -- they will be transferred to the newly created block.
9008 Insert_Actions_In_Scope_Around
9009 (Action
, Clean
=> False, Manage_SS
=> False);
9011 Insert
:= Prev
(Action
);
9013 if Present
(Insert
) then
9014 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9017 -- Transfer cleanup actions to the newly created block
9020 Cleanup_Actions
: List_Id
9021 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9022 Actions_To_Be_Wrapped
(Cleanup
);
9024 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9025 Cleanup_Actions
:= No_List
;
9028 -- When the transient scope was established, we pushed the entry for the
9029 -- transient scope onto the scope stack, so that the scope was active
9030 -- for the installation of finalizable entities etc. Now we must remove
9031 -- this entry, since we have constructed a proper block.
9036 end Make_Transient_Block
;
9038 ------------------------
9039 -- Node_To_Be_Wrapped --
9040 ------------------------
9042 function Node_To_Be_Wrapped
return Node_Id
is
9044 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9045 end Node_To_Be_Wrapped
;
9047 ----------------------------
9048 -- Set_Node_To_Be_Wrapped --
9049 ----------------------------
9051 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
9053 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
9054 end Set_Node_To_Be_Wrapped
;
9056 ----------------------------
9057 -- Store_Actions_In_Scope --
9058 ----------------------------
9060 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9061 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9062 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9065 if No
(Actions
) then
9068 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9069 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9071 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9076 elsif AK
= Before
then
9077 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9080 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9082 end Store_Actions_In_Scope
;
9084 ----------------------------------
9085 -- Store_After_Actions_In_Scope --
9086 ----------------------------------
9088 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9090 Store_Actions_In_Scope
(After
, L
);
9091 end Store_After_Actions_In_Scope
;
9093 -----------------------------------
9094 -- Store_Before_Actions_In_Scope --
9095 -----------------------------------
9097 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9099 Store_Actions_In_Scope
(Before
, L
);
9100 end Store_Before_Actions_In_Scope
;
9102 -----------------------------------
9103 -- Store_Cleanup_Actions_In_Scope --
9104 -----------------------------------
9106 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9108 Store_Actions_In_Scope
(Cleanup
, L
);
9109 end Store_Cleanup_Actions_In_Scope
;
9111 --------------------------------
9112 -- Wrap_Transient_Declaration --
9113 --------------------------------
9115 -- If a transient scope has been established during the processing of the
9116 -- Expression of an Object_Declaration, it is not possible to wrap the
9117 -- declaration into a transient block as usual case, otherwise the object
9118 -- would be itself declared in the wrong scope. Therefore, all entities (if
9119 -- any) defined in the transient block are moved to the proper enclosing
9120 -- scope. Furthermore, if they are controlled variables they are finalized
9121 -- right after the declaration. The finalization list of the transient
9122 -- scope is defined as a renaming of the enclosing one so during their
9123 -- initialization they will be attached to the proper finalization list.
9124 -- For instance, the following declaration :
9126 -- X : Typ := F (G (A), G (B));
9128 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9129 -- is expanded into :
9131 -- X : Typ := [ complex Expression-Action ];
9132 -- [Deep_]Finalize (_v1);
9133 -- [Deep_]Finalize (_v2);
9135 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9140 Curr_S
:= Current_Scope
;
9141 Encl_S
:= Scope
(Curr_S
);
9143 -- Insert all actions including cleanup generated while analyzing or
9144 -- expanding the transient context back into the tree. Manage the
9145 -- secondary stack when the object declaration appears in a library
9146 -- level package [body].
9148 Insert_Actions_In_Scope_Around
9152 Uses_Sec_Stack
(Curr_S
)
9153 and then Nkind
(N
) = N_Object_Declaration
9154 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
9155 and then Is_Library_Level_Entity
(Encl_S
));
9158 -- Relocate local entities declared within the transient scope to the
9159 -- enclosing scope. This action sets their Is_Public flag accordingly.
9161 Transfer_Entities
(Curr_S
, Encl_S
);
9163 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9164 -- is properly released upon exiting the said scope.
9166 if Uses_Sec_Stack
(Curr_S
) then
9167 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9169 -- Do not mark a function that returns on the secondary stack as the
9170 -- reclamation is done by the caller.
9172 if Ekind
(Curr_S
) = E_Function
9173 and then Requires_Transient_Scope
(Etype
(Curr_S
))
9177 -- Otherwise mark the enclosing dynamic scope
9180 Set_Uses_Sec_Stack
(Curr_S
);
9181 Check_Restriction
(No_Secondary_Stack
, N
);
9184 end Wrap_Transient_Declaration
;
9186 -------------------------------
9187 -- Wrap_Transient_Expression --
9188 -------------------------------
9190 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9191 Loc
: constant Source_Ptr
:= Sloc
(N
);
9192 Expr
: Node_Id
:= Relocate_Node
(N
);
9193 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9194 Typ
: constant Entity_Id
:= Etype
(N
);
9201 -- M : constant Mark_Id := SS_Mark;
9202 -- procedure Finalizer is ... (See Build_Finalizer)
9205 -- Temp := <Expr>; -- general case
9206 -- Temp := (if <Expr> then True else False); -- boolean case
9212 -- A special case is made for Boolean expressions so that the back end
9213 -- knows to generate a conditional branch instruction, if running with
9214 -- -fpreserve-control-flow. This ensures that a control-flow change
9215 -- signaling the decision outcome occurs before the cleanup actions.
9217 if Opt
.Suppress_Control_Flow_Optimizations
9218 and then Is_Boolean_Type
(Typ
)
9221 Make_If_Expression
(Loc
,
9222 Expressions
=> New_List
(
9224 New_Occurrence_Of
(Standard_True
, Loc
),
9225 New_Occurrence_Of
(Standard_False
, Loc
)));
9228 Insert_Actions
(N
, New_List
(
9229 Make_Object_Declaration
(Loc
,
9230 Defining_Identifier
=> Temp
,
9231 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9233 Make_Transient_Block
(Loc
,
9235 Make_Assignment_Statement
(Loc
,
9236 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9237 Expression
=> Expr
),
9238 Par
=> Parent
(N
))));
9240 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9241 Analyze_And_Resolve
(N
, Typ
);
9242 end Wrap_Transient_Expression
;
9244 ------------------------------
9245 -- Wrap_Transient_Statement --
9246 ------------------------------
9248 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9249 Loc
: constant Source_Ptr
:= Sloc
(N
);
9250 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9255 -- M : constant Mark_Id := SS_Mark;
9256 -- procedure Finalizer is ... (See Build_Finalizer)
9266 Make_Transient_Block
(Loc
,
9268 Par
=> Parent
(N
)));
9270 -- With the scope stack back to normal, we can call analyze on the
9271 -- resulting block. At this point, the transient scope is being
9272 -- treated like a perfectly normal scope, so there is nothing
9273 -- special about it.
9275 -- Note: Wrap_Transient_Statement is called with the node already
9276 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9277 -- otherwise we would get a recursive processing of the node when
9278 -- we do this Analyze call.
9281 end Wrap_Transient_Statement
;