1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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 Contracts
; use Contracts
;
32 with Debug
; use Debug
;
33 with Einfo
; use Einfo
;
34 with Einfo
.Entities
; use Einfo
.Entities
;
35 with Einfo
.Utils
; use Einfo
.Utils
;
36 with Elists
; use Elists
;
37 with Errout
; use Errout
;
38 with Exp_Ch6
; use Exp_Ch6
;
39 with Exp_Ch9
; use Exp_Ch9
;
40 with Exp_Ch11
; use Exp_Ch11
;
41 with Exp_Dbug
; use Exp_Dbug
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Disp
; use Exp_Disp
;
44 with Exp_Prag
; use Exp_Prag
;
45 with Exp_Tss
; use Exp_Tss
;
46 with Exp_Util
; use Exp_Util
;
47 with Freeze
; use Freeze
;
48 with GNAT_CUDA
; use GNAT_CUDA
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
53 with Output
; use Output
;
54 with Restrict
; use Restrict
;
55 with Rident
; use Rident
;
56 with Rtsfind
; use Rtsfind
;
57 with Sinfo
; use Sinfo
;
58 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
59 with Sinfo
.Utils
; use Sinfo
.Utils
;
61 with Sem_Aux
; use Sem_Aux
;
62 with Sem_Ch3
; use Sem_Ch3
;
63 with Sem_Ch7
; use Sem_Ch7
;
64 with Sem_Ch8
; use Sem_Ch8
;
65 with Sem_Res
; use Sem_Res
;
66 with Sem_Util
; use Sem_Util
;
67 with Snames
; use Snames
;
68 with Stand
; use Stand
;
69 with Tbuild
; use Tbuild
;
70 with Ttypes
; use Ttypes
;
71 with Uintp
; use Uintp
;
73 package body Exp_Ch7
is
75 --------------------------------
76 -- Transient Scope Management --
77 --------------------------------
79 -- A transient scope is created when temporary objects are created by the
80 -- compiler. These temporary objects are allocated on the secondary stack
81 -- and the transient scope is responsible for finalizing the object when
82 -- appropriate and reclaiming the memory at the right time. The temporary
83 -- objects are generally the objects allocated to store the result of a
84 -- function returning an unconstrained or a tagged value. Expressions
85 -- needing to be wrapped in a transient scope (functions calls returning
86 -- unconstrained or tagged values) may appear in 3 different contexts which
87 -- lead to 3 different kinds of transient scope expansion:
89 -- 1. In a simple statement (procedure call, assignment, ...). In this
90 -- case the instruction is wrapped into a transient block. See
91 -- Wrap_Transient_Statement for details.
93 -- 2. In an expression of a control structure (test in a IF statement,
94 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
97 -- 3. In a expression of an object_declaration. No wrapping is possible
98 -- here, so the finalization actions, if any, are done right after the
99 -- declaration and the secondary stack deallocation is done in the
100 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
102 -- Note about functions returning tagged types: it has been decided to
103 -- always allocate their result in the secondary stack, even though is not
104 -- absolutely mandatory when the tagged type is constrained because the
105 -- caller knows the size of the returned object and thus could allocate the
106 -- result in the primary stack. An exception to this is when the function
107 -- builds its result in place, as is done for functions with inherently
108 -- limited result types for Ada 2005. In that case, certain callers may
109 -- pass the address of a constrained object as the target object for the
112 -- By allocating tagged results in the secondary stack a number of
113 -- implementation difficulties are avoided:
115 -- - If it is a dispatching function call, the computation of the size of
116 -- the result is possible but complex from the outside.
118 -- - If the returned type is controlled, the assignment of the returned
119 -- value to the anonymous object involves an Adjust, and we have no
120 -- easy way to access the anonymous object created by the back end.
122 -- - If the returned type is class-wide, this is an unconstrained type
125 -- Furthermore, the small loss in efficiency which is the result of this
126 -- decision is not such a big deal because functions returning tagged types
127 -- are not as common in practice compared to functions returning access to
130 --------------------------------------------------
131 -- Transient Blocks and Finalization Management --
132 --------------------------------------------------
134 procedure Insert_Actions_In_Scope_Around
137 Manage_SS
: Boolean);
138 -- Insert the before-actions kept in the scope stack before N, and the
139 -- after-actions after N, which must be a member of a list. If flag Clean
140 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
141 -- calls to mark and release the secondary stack.
143 function Make_Transient_Block
146 Par
: Node_Id
) return Node_Id
;
147 -- Action is a single statement or object declaration. Par is the proper
148 -- parent of the generated block. Create a transient block whose name is
149 -- the current scope and the only handled statement is Action. If Action
150 -- involves controlled objects or secondary stack usage, the corresponding
151 -- cleanup actions are performed at the end of the block.
153 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
154 -- Shared processing for Store_xxx_Actions_In_Scope
156 -----------------------------
157 -- Finalization Management --
158 -----------------------------
160 -- This part describe how Initialization/Adjustment/Finalization procedures
161 -- are generated and called. Two cases must be considered, types that are
162 -- Controlled (Is_Controlled flag set) and composite types that contain
163 -- controlled components (Has_Controlled_Component flag set). In the first
164 -- case the procedures to call are the user-defined primitive operations
165 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
166 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
167 -- of calling the former procedures on the controlled components.
169 -- For records with Has_Controlled_Component set, a hidden "controller"
170 -- component is inserted. This controller component contains its own
171 -- finalization list on which all controlled components are attached
172 -- creating an indirection on the upper-level Finalization list. This
173 -- technique facilitates the management of objects whose number of
174 -- controlled components changes during execution. This controller
175 -- component is itself controlled and is attached to the upper-level
176 -- finalization chain. Its adjust primitive is in charge of calling adjust
177 -- on the components and adjusting the finalization pointer to match their
178 -- new location (see a-finali.adb).
180 -- It is not possible to use a similar technique for arrays that have
181 -- Has_Controlled_Component set. In this case, deep procedures are
182 -- generated that call initialize/adjust/finalize + attachment or
183 -- detachment on the finalization list for all component.
185 -- Initialize calls: they are generated for declarations or dynamic
186 -- allocations of Controlled objects with no initial value. They are always
187 -- followed by an attachment to the current Finalization Chain. For the
188 -- dynamic allocation case this the chain attached to the scope of the
189 -- access type definition otherwise, this is the chain of the current
192 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
193 -- or dynamic allocations of Controlled objects with an initial value.
194 -- (2) after an assignment. In the first case they are followed by an
195 -- attachment to the final chain, in the second case they are not.
197 -- Finalization Calls: They are generated on (1) scope exit, (2)
198 -- assignments, (3) unchecked deallocations. In case (3) they have to
199 -- be detached from the final chain, in case (2) they must not and in
200 -- case (1) this is not important since we are exiting the scope anyway.
204 -- Type extensions will have a new record controller at each derivation
205 -- level containing controlled components. The record controller for
206 -- the parent/ancestor is attached to the finalization list of the
207 -- extension's record controller (i.e. the parent is like a component
208 -- of the extension).
210 -- For types that are both Is_Controlled and Has_Controlled_Components,
211 -- the record controller and the object itself are handled separately.
212 -- It could seem simpler to attach the object at the end of its record
213 -- controller but this would not tackle view conversions properly.
215 -- A classwide type can always potentially have controlled components
216 -- but the record controller of the corresponding actual type may not
217 -- be known at compile time so the dispatch table contains a special
218 -- field that allows computation of the offset of the record controller
219 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
221 -- Here is a simple example of the expansion of a controlled block :
225 -- Y : Controlled := Init;
231 -- Z : R := (C => X);
241 -- _L : System.FI.Finalizable_Ptr;
243 -- procedure _Clean is
246 -- System.FI.Finalize_List (_L);
254 -- Attach_To_Final_List (_L, Finalizable (X), 1);
255 -- at end: Abort_Undefer;
256 -- Y : Controlled := Init;
258 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
266 -- Deep_Initialize (W, _L, 1);
267 -- at end: Abort_Under;
268 -- Z : R := (C => X);
269 -- Deep_Adjust (Z, _L, 1);
273 -- Deep_Finalize (W, False);
274 -- <save W's final pointers>
276 -- <restore W's final pointers>
277 -- Deep_Adjust (W, _L, 0);
282 type Final_Primitives
is
283 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
284 -- This enumeration type is defined in order to ease sharing code for
285 -- building finalization procedures for composite types.
287 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
288 (Initialize_Case
=> Name_Initialize
,
289 Adjust_Case
=> Name_Adjust
,
290 Finalize_Case
=> Name_Finalize
,
291 Address_Case
=> Name_Finalize_Address
);
292 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
293 (Initialize_Case
=> TSS_Deep_Initialize
,
294 Adjust_Case
=> TSS_Deep_Adjust
,
295 Finalize_Case
=> TSS_Deep_Finalize
,
296 Address_Case
=> TSS_Finalize_Address
);
298 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
299 -- Determine whether access type Typ may have a finalization master
301 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
302 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
303 -- Has_Controlled_Component set and store them using the TSS mechanism.
305 function Build_Cleanup_Statements
307 Additional_Cleanup
: List_Id
) return List_Id
;
308 -- Create the cleanup calls for an asynchronous call block, task master,
309 -- protected subprogram body, task allocation block or task body, or
310 -- additional cleanup actions parked on a transient block. If the context
311 -- does not contain the above constructs, the routine returns an empty
314 procedure Build_Finalizer
316 Clean_Stmts
: List_Id
;
319 Defer_Abort
: Boolean;
320 Fin_Id
: out Entity_Id
);
321 -- N may denote an accept statement, block, entry body, package body,
322 -- package spec, protected body, subprogram body, or a task body. Create
323 -- a procedure which contains finalization calls for all controlled objects
324 -- declared in the declarative or statement region of N. The calls are
325 -- built in reverse order relative to the original declarations. In the
326 -- case of a task body, the routine delays the creation of the finalizer
327 -- until all statements have been moved to the task body procedure.
328 -- Clean_Stmts may contain additional context-dependent code used to abort
329 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
330 -- Mark_Id is the secondary stack used in the current context or Empty if
331 -- missing. Top_Decls is the list on which the declaration of the finalizer
332 -- is attached in the non-package case. Defer_Abort indicates that the
333 -- statements passed in perform actions that require abort to be deferred,
334 -- such as for task termination. Fin_Id is the finalizer declaration
337 procedure Build_Finalizer_Helper
339 Clean_Stmts
: List_Id
;
342 Defer_Abort
: Boolean;
343 Fin_Id
: out Entity_Id
;
344 Finalize_Old_Only
: Boolean);
345 -- An internal routine which does all of the heavy lifting on behalf of
348 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
349 -- N is a construct which contains a handled sequence of statements, Fin_Id
350 -- is the entity of a finalizer. Create an At_End handler which covers the
351 -- statements of N and calls Fin_Id. If the handled statement sequence has
352 -- an exception handler, the statements will be wrapped in a block to avoid
353 -- unwanted interaction with the new At_End handler.
355 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
356 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
357 -- Has_Component_Component set and store them using the TSS mechanism.
359 -------------------------------------------
360 -- Unnesting procedures for CCG and LLVM --
361 -------------------------------------------
363 -- Expansion generates subprograms for controlled types management that
364 -- may appear in declarative lists in package declarations and bodies.
365 -- These subprograms appear within generated blocks that contain local
366 -- declarations and a call to finalization procedures. To ensure that
367 -- such subprograms get activation records when needed, we transform the
368 -- block into a procedure body, followed by a call to it in the same
371 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
372 -- The statement part of a package body that is a compilation unit may
373 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
374 -- Mode such subprograms must be handled as nested inside the (implicit)
375 -- elaboration procedure that executes that statement part. To handle
376 -- properly uplevel references we construct that subprogram explicitly,
377 -- to contain blocks and inner subprograms, the statement part becomes
378 -- a call to this subprogram. This is only done if blocks are present
379 -- in the statement list of the body. (It would be nice to unify this
380 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
381 -- they're doing very similar work, but are structured differently. ???)
383 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
384 -- Similarly, the declarations or statements in library-level packages may
385 -- have created blocks with nested subprograms. Such a block must be
386 -- transformed into a procedure followed by a call to it, so that unnesting
387 -- can handle uplevel references within these nested subprograms (typically
388 -- subprograms that handle finalization actions). This also applies to
389 -- nested packages, including instantiations, in which case it must
390 -- recursively process inner bodies.
392 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
393 -- Similarly, check for blocks with nested subprograms occurring within
394 -- a set of exception handlers associated with a package body N.
396 procedure Unnest_Block
(Decl
: Node_Id
);
397 -- Blocks that contain nested subprograms with up-level references need to
398 -- create activation records for them. We do this by rewriting the block as
399 -- a procedure, followed by a call to it in the same declarative list, to
400 -- replicate the semantics of the original block.
402 -- A common source for such block is a transient block created for a
403 -- construct (declaration, assignment, etc.) that involves controlled
404 -- actions or secondary-stack management, in which case the nested
405 -- subprogram is a finalizer.
407 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
408 -- The separate statement lists associated with an if-statement (then part,
409 -- elsif parts, else part) may require unnesting if they directly contain
410 -- a subprogram body that references up-level objects. Each statement list
411 -- is traversed to locate such subprogram bodies, and if a part's statement
412 -- list contains a body, then the list is replaced with a new procedure
413 -- containing the part's statements followed by a call to the procedure.
414 -- Furthermore, any nested blocks, loops, or if statements will also be
415 -- traversed to determine the need for further unnesting transformations.
417 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
418 -- A list of statements that directly contains a subprogram at its outer
419 -- level, that may reference objects declared in that same statement list,
420 -- is rewritten as a procedure containing the statement list Stmts (which
421 -- includes any such objects as well as the nested subprogram), followed by
422 -- a call to the new procedure, and Stmts becomes the list containing the
423 -- procedure and the call. This ensures that Unnest_Subprogram will later
424 -- properly handle up-level references from the nested subprogram to
425 -- objects declared earlier in statement list, by creating an activation
426 -- record and passing it to the nested subprogram. This procedure also
427 -- resets the Scope of objects declared in the statement list, as well as
428 -- the Scope of the nested subprogram, to refer to the new procedure.
429 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
430 -- only be called when known that the statement list contains a subprogram.
432 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
433 -- Top-level Loops that contain nested subprograms with up-level references
434 -- need to have activation records. We do this by rewriting the loop as a
435 -- procedure containing the loop, followed by a call to the procedure in
436 -- the same library-level declarative list, to replicate the semantics of
437 -- the original loop. Such loops can occur due to aggregate expansions and
440 procedure Check_Visibly_Controlled
441 (Prim
: Final_Primitives
;
443 E
: in out Entity_Id
;
444 Cref
: in out Node_Id
);
445 -- The controlled operation declared for a derived type may not be
446 -- overriding, if the controlled operations of the parent type are hidden,
447 -- for example when the parent is a private type whose full view is
448 -- controlled. For other primitive operations we modify the name of the
449 -- operation to indicate that it is not overriding, but this is not
450 -- possible for Initialize, etc. because they have to be retrievable by
451 -- name. Before generating the proper call to one of these operations we
452 -- check whether Typ is known to be controlled at the point of definition.
453 -- If it is not then we must retrieve the hidden operation of the parent
454 -- and use it instead. This is one case that might be solved more cleanly
455 -- once Overriding pragmas or declarations are in place.
457 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
458 -- Check recursively whether a loop or block contains a subprogram that
459 -- may need an activation record.
461 function Convert_View
464 Ind
: Pos
:= 1) return Node_Id
;
465 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
466 -- argument being passed to it. Ind indicates which formal of procedure
467 -- Proc we are trying to match. This function will, if necessary, generate
468 -- a conversion between the partial and full view of Arg to match the type
469 -- of the formal of Proc, or force a conversion to the class-wide type in
470 -- the case where the operation is abstract.
472 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
473 -- Given an arbitrary entity, traverse the scope chain looking for the
474 -- first enclosing function. Return Empty if no function was found.
480 Skip_Self
: Boolean := False) return Node_Id
;
481 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
482 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
483 -- an adjust or finalization call. When flag Skip_Self is set, the related
484 -- action has an effect on the components only (if any).
486 function Make_Deep_Proc
487 (Prim
: Final_Primitives
;
489 Stmts
: List_Id
) return Entity_Id
;
490 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
491 -- Deep_Finalize procedures according to the first parameter. These
492 -- procedures operate on the type Typ. The Stmts parameter gives the
493 -- body of the procedure.
495 function Make_Deep_Array_Body
496 (Prim
: Final_Primitives
;
497 Typ
: Entity_Id
) return List_Id
;
498 -- This function generates the list of statements for implementing
499 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
500 -- the first parameter, these procedures operate on the array type Typ.
502 function Make_Deep_Record_Body
503 (Prim
: Final_Primitives
;
505 Is_Local
: Boolean := False) return List_Id
;
506 -- This function generates the list of statements for implementing
507 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
508 -- the first parameter, these procedures operate on the record type Typ.
509 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
510 -- whether the inner logic should be dictated by state counters.
512 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
513 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
514 -- Make_Deep_Record_Body. Generate the following statements:
517 -- type Acc_Typ is access all Typ;
518 -- for Acc_Typ'Storage_Size use 0;
520 -- [Deep_]Finalize (Acc_Typ (V).all);
523 --------------------------------
524 -- Allows_Finalization_Master --
525 --------------------------------
527 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
528 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
529 -- Determine whether entity E is inside a wrapper package created for
530 -- an instance of Ada.Unchecked_Deallocation.
532 ------------------------------
533 -- In_Deallocation_Instance --
534 ------------------------------
536 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
537 Pkg
: constant Entity_Id
:= Scope
(E
);
538 Par
: Node_Id
:= Empty
;
541 if Ekind
(Pkg
) = E_Package
542 and then Present
(Related_Instance
(Pkg
))
543 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
545 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
549 and then Chars
(Par
) = Name_Unchecked_Deallocation
550 and then Chars
(Scope
(Par
)) = Name_Ada
551 and then Scope
(Scope
(Par
)) = Standard_Standard
;
555 end In_Deallocation_Instance
;
559 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
560 Ptr_Typ
: constant Entity_Id
:=
561 Root_Type_Of_Full_View
(Base_Type
(Typ
));
563 -- Start of processing for Allows_Finalization_Master
566 -- Certain run-time configurations and targets do not provide support
567 -- for controlled types and therefore do not need masters.
569 if Restriction_Active
(No_Finalization
) then
572 -- Do not consider C and C++ types since it is assumed that the non-Ada
573 -- side will handle their cleanup.
575 elsif Convention
(Desig_Typ
) = Convention_C
576 or else Convention
(Desig_Typ
) = Convention_CPP
580 -- Do not consider an access type that returns on the secondary stack
582 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
583 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
587 -- Do not consider an access type that can never allocate an object
589 elsif No_Pool_Assigned
(Ptr_Typ
) then
592 -- Do not consider an access type coming from an Unchecked_Deallocation
593 -- instance. Even though the designated type may be controlled, the
594 -- access type will never participate in any allocations.
596 elsif In_Deallocation_Instance
(Ptr_Typ
) then
599 -- Do not consider a non-library access type when No_Nested_Finalization
600 -- is in effect since finalization masters are controlled objects and if
601 -- created will violate the restriction.
603 elsif Restriction_Active
(No_Nested_Finalization
)
604 and then not Is_Library_Level_Entity
(Ptr_Typ
)
608 -- Do not consider an access type subject to pragma No_Heap_Finalization
609 -- because objects allocated through such a type are not to be finalized
610 -- when the access type goes out of scope.
612 elsif No_Heap_Finalization
(Ptr_Typ
) then
615 -- Do not create finalization masters in GNATprove mode because this
616 -- causes unwanted extra expansion. A compilation in this mode must
617 -- keep the tree as close as possible to the original sources.
619 elsif GNATprove_Mode
then
622 -- Otherwise the access type may use a finalization master
627 end Allows_Finalization_Master
;
629 ----------------------------
630 -- Build_Anonymous_Master --
631 ----------------------------
633 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
634 function Create_Anonymous_Master
635 (Desig_Typ
: Entity_Id
;
637 Unit_Decl
: Node_Id
) return Entity_Id
;
638 -- Create a new anonymous master for access type Ptr_Typ with designated
639 -- type Desig_Typ. The declaration of the master and its initialization
640 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
641 -- the entity of Unit_Decl.
643 function Current_Anonymous_Master
644 (Desig_Typ
: Entity_Id
;
645 Unit_Id
: Entity_Id
) return Entity_Id
;
646 -- Find an anonymous master declared within unit Unit_Id which services
647 -- designated type Desig_Typ. If there is no such master, return Empty.
649 -----------------------------
650 -- Create_Anonymous_Master --
651 -----------------------------
653 function Create_Anonymous_Master
654 (Desig_Typ
: Entity_Id
;
656 Unit_Decl
: Node_Id
) return Entity_Id
658 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
669 -- <FM_Id> : Finalization_Master;
671 FM_Id
:= Make_Temporary
(Loc
, 'A');
674 Make_Object_Declaration
(Loc
,
675 Defining_Identifier
=> FM_Id
,
677 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
681 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
684 Make_Procedure_Call_Statement
(Loc
,
686 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
687 Parameter_Associations
=> New_List
(
688 New_Occurrence_Of
(FM_Id
, Loc
),
689 Make_Attribute_Reference
(Loc
,
691 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
692 Attribute_Name
=> Name_Unrestricted_Access
)));
694 -- Find the declarative list of the unit
696 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
697 Unit_Spec
:= Specification
(Unit_Decl
);
698 Decls
:= Visible_Declarations
(Unit_Spec
);
702 Set_Visible_Declarations
(Unit_Spec
, Decls
);
705 -- Package body or subprogram case
707 -- ??? A subprogram spec or body that acts as a compilation unit may
708 -- contain a formal parameter of an anonymous access-to-controlled
709 -- type initialized by an allocator.
711 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
713 -- There is no suitable place to create the master as the subprogram
714 -- is not in a declarative list.
717 Decls
:= Declarations
(Unit_Decl
);
721 Set_Declarations
(Unit_Decl
, Decls
);
725 Prepend_To
(Decls
, FM_Init
);
726 Prepend_To
(Decls
, FM_Decl
);
728 -- Use the scope of the unit when analyzing the declaration of the
729 -- master and its initialization actions.
731 Push_Scope
(Unit_Id
);
736 -- Mark the master as servicing this specific designated type
738 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
740 -- Include the anonymous master in the list of existing masters which
741 -- appear in this unit. This effectively creates a mapping between a
742 -- master and a designated type which in turn allows for the reuse of
743 -- masters on a per-unit basis.
745 All_FMs
:= Anonymous_Masters
(Unit_Id
);
748 All_FMs
:= New_Elmt_List
;
749 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
752 Prepend_Elmt
(FM_Id
, All_FMs
);
755 end Create_Anonymous_Master
;
757 ------------------------------
758 -- Current_Anonymous_Master --
759 ------------------------------
761 function Current_Anonymous_Master
762 (Desig_Typ
: Entity_Id
;
763 Unit_Id
: Entity_Id
) return Entity_Id
765 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
770 -- Inspect the list of anonymous masters declared within the unit
771 -- looking for an existing master which services the same designated
774 if Present
(All_FMs
) then
775 FM_Elmt
:= First_Elmt
(All_FMs
);
776 while Present
(FM_Elmt
) loop
777 FM_Id
:= Node
(FM_Elmt
);
779 -- The currect master services the same designated type. As a
780 -- result the master can be reused and associated with another
781 -- anonymous access-to-controlled type.
783 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
792 end Current_Anonymous_Master
;
796 Desig_Typ
: Entity_Id
;
798 Priv_View
: Entity_Id
;
802 -- Start of processing for Build_Anonymous_Master
805 -- Nothing to do if the circumstances do not allow for a finalization
808 if not Allows_Finalization_Master
(Ptr_Typ
) then
812 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
813 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
815 -- The compilation unit is a package instantiation. In this case the
816 -- anonymous master is associated with the package spec as both the
817 -- spec and body appear at the same level.
819 if Nkind
(Unit_Decl
) = N_Package_Body
820 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
822 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
823 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
826 -- Use the initial declaration of the designated type when it denotes
827 -- the full view of an incomplete or private type. This ensures that
828 -- types with one and two views are treated the same.
830 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
831 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
833 if Present
(Priv_View
) then
834 Desig_Typ
:= Priv_View
;
837 -- Determine whether the current semantic unit already has an anonymous
838 -- master which services the designated type.
840 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
842 -- If this is not the case, create a new master
845 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
848 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
849 end Build_Anonymous_Master
;
851 ----------------------------
852 -- Build_Array_Deep_Procs --
853 ----------------------------
855 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
859 (Prim
=> Initialize_Case
,
861 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
863 if not Is_Limited_View
(Typ
) then
866 (Prim
=> Adjust_Case
,
868 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
871 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
872 -- suppressed since these routine will not be used.
874 if not Restriction_Active
(No_Finalization
) then
877 (Prim
=> Finalize_Case
,
879 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
881 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
883 if not CodePeer_Mode
then
886 (Prim
=> Address_Case
,
888 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
891 end Build_Array_Deep_Procs
;
893 ------------------------------
894 -- Build_Cleanup_Statements --
895 ------------------------------
897 function Build_Cleanup_Statements
899 Additional_Cleanup
: List_Id
) return List_Id
901 Is_Asynchronous_Call
: constant Boolean :=
902 Nkind
(N
) = N_Block_Statement
903 and then Is_Asynchronous_Call_Block
(N
);
904 Is_Master
: constant Boolean :=
905 Nkind
(N
) /= N_Entry_Body
906 and then Is_Task_Master
(N
);
907 Is_Protected_Body
: constant Boolean :=
908 Nkind
(N
) = N_Subprogram_Body
909 and then Is_Protected_Subprogram_Body
(N
);
910 Is_Task_Allocation
: constant Boolean :=
911 Nkind
(N
) = N_Block_Statement
912 and then Is_Task_Allocation_Block
(N
);
913 Is_Task_Body
: constant Boolean :=
914 Nkind
(Original_Node
(N
)) = N_Task_Body
;
916 Loc
: constant Source_Ptr
:= Sloc
(N
);
917 Stmts
: constant List_Id
:= New_List
;
921 if Restricted_Profile
then
923 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
925 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
929 if Restriction_Active
(No_Task_Hierarchy
) = False then
930 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
933 -- Add statements to unlock the protected object parameter and to
934 -- undefer abort. If the context is a protected procedure and the object
935 -- has entries, call the entry service routine.
937 -- NOTE: The generated code references _object, a parameter to the
940 elsif Is_Protected_Body
then
942 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
943 Conc_Typ
: Entity_Id
:= Empty
;
945 Param_Typ
: Entity_Id
;
948 -- Find the _object parameter representing the protected object
950 Param
:= First
(Parameter_Specifications
(Spec
));
952 Param_Typ
:= Etype
(Parameter_Type
(Param
));
954 if Ekind
(Param_Typ
) = E_Record_Type
then
955 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
958 exit when No
(Param
) or else Present
(Conc_Typ
);
962 pragma Assert
(Present
(Param
));
963 pragma Assert
(Present
(Conc_Typ
));
965 -- Historical note: In earlier versions of GNAT, there was code
966 -- at this point to generate stuff to service entry queues. It is
967 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
969 Build_Protected_Subprogram_Call_Cleanup
970 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
973 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
974 -- tasks. Other unactivated tasks are completed by Complete_Task or
977 -- NOTE: The generated code references _chain, a local object
979 elsif Is_Task_Allocation
then
982 -- Expunge_Unactivated_Tasks (_chain);
984 -- where _chain is the list of tasks created by the allocator but not
985 -- yet activated. This list will be empty unless the block completes
989 Make_Procedure_Call_Statement
(Loc
,
992 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
993 Parameter_Associations
=> New_List
(
994 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
996 -- Attempt to cancel an asynchronous entry call whenever the block which
997 -- contains the abortable part is exited.
999 -- NOTE: The generated code references Cnn, a local object
1001 elsif Is_Asynchronous_Call
then
1003 Cancel_Param
: constant Entity_Id
:=
1004 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
1007 -- If it is of type Communication_Block, this must be a protected
1008 -- entry call. Generate:
1010 -- if Enqueued (Cancel_Param) then
1011 -- Cancel_Protected_Entry_Call (Cancel_Param);
1014 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
1016 Make_If_Statement
(Loc
,
1018 Make_Function_Call
(Loc
,
1020 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
1021 Parameter_Associations
=> New_List
(
1022 New_Occurrence_Of
(Cancel_Param
, Loc
))),
1024 Then_Statements
=> New_List
(
1025 Make_Procedure_Call_Statement
(Loc
,
1028 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
1029 Parameter_Associations
=> New_List
(
1030 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
1032 -- Asynchronous delay, generate:
1033 -- Cancel_Async_Delay (Cancel_Param);
1035 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
1037 Make_Procedure_Call_Statement
(Loc
,
1039 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
1040 Parameter_Associations
=> New_List
(
1041 Make_Attribute_Reference
(Loc
,
1043 New_Occurrence_Of
(Cancel_Param
, Loc
),
1044 Attribute_Name
=> Name_Unchecked_Access
))));
1046 -- Task entry call, generate:
1047 -- Cancel_Task_Entry_Call (Cancel_Param);
1051 Make_Procedure_Call_Statement
(Loc
,
1053 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
1054 Parameter_Associations
=> New_List
(
1055 New_Occurrence_Of
(Cancel_Param
, Loc
))));
1060 Append_List_To
(Stmts
, Additional_Cleanup
);
1062 end Build_Cleanup_Statements
;
1064 -----------------------------
1065 -- Build_Controlling_Procs --
1066 -----------------------------
1068 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
1070 if Is_Array_Type
(Typ
) then
1071 Build_Array_Deep_Procs
(Typ
);
1072 else pragma Assert
(Is_Record_Type
(Typ
));
1073 Build_Record_Deep_Procs
(Typ
);
1075 end Build_Controlling_Procs
;
1077 -----------------------------
1078 -- Build_Exception_Handler --
1079 -----------------------------
1081 function Build_Exception_Handler
1082 (Data
: Finalization_Exception_Data
;
1083 For_Library
: Boolean := False) return Node_Id
1086 Proc_To_Call
: Entity_Id
;
1091 pragma Assert
(Present
(Data
.Raised_Id
));
1093 if Exception_Extra_Info
1094 or else (For_Library
and not Restricted_Profile
)
1096 if Exception_Extra_Info
then
1100 -- Get_Current_Excep.all
1103 Make_Function_Call
(Data
.Loc
,
1105 Make_Explicit_Dereference
(Data
.Loc
,
1108 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1115 Except
:= Make_Null
(Data
.Loc
);
1118 if For_Library
and then not Restricted_Profile
then
1119 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1120 Actuals
:= New_List
(Except
);
1123 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1125 -- The dereference occurs only when Exception_Extra_Info is true,
1126 -- and therefore Except is not null.
1130 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1131 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1137 -- if not Raised_Id then
1138 -- Raised_Id := True;
1140 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1142 -- Save_Library_Occurrence (Get_Current_Excep.all);
1147 Make_If_Statement
(Data
.Loc
,
1149 Make_Op_Not
(Data
.Loc
,
1150 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1152 Then_Statements
=> New_List
(
1153 Make_Assignment_Statement
(Data
.Loc
,
1154 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1155 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1157 Make_Procedure_Call_Statement
(Data
.Loc
,
1159 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1160 Parameter_Associations
=> Actuals
))));
1165 -- Raised_Id := True;
1168 Make_Assignment_Statement
(Data
.Loc
,
1169 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1170 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1178 Make_Exception_Handler
(Data
.Loc
,
1179 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1180 Statements
=> Stmts
);
1181 end Build_Exception_Handler
;
1183 -------------------------------
1184 -- Build_Finalization_Master --
1185 -------------------------------
1187 procedure Build_Finalization_Master
1189 For_Lib_Level
: Boolean := False;
1190 For_Private
: Boolean := False;
1191 Context_Scope
: Entity_Id
:= Empty
;
1192 Insertion_Node
: Node_Id
:= Empty
)
1194 procedure Add_Pending_Access_Type
1196 Ptr_Typ
: Entity_Id
);
1197 -- Add access type Ptr_Typ to the pending access type list for type Typ
1199 -----------------------------
1200 -- Add_Pending_Access_Type --
1201 -----------------------------
1203 procedure Add_Pending_Access_Type
1205 Ptr_Typ
: Entity_Id
)
1210 if Present
(Pending_Access_Types
(Typ
)) then
1211 List
:= Pending_Access_Types
(Typ
);
1213 List
:= New_Elmt_List
;
1214 Set_Pending_Access_Types
(Typ
, List
);
1217 Prepend_Elmt
(Ptr_Typ
, List
);
1218 end Add_Pending_Access_Type
;
1222 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1224 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1225 -- A finalization master created for a named access type is associated
1226 -- with the full view (if applicable) as a consequence of freezing. The
1227 -- full view criteria does not apply to anonymous access types because
1228 -- those cannot have a private and a full view.
1230 -- Start of processing for Build_Finalization_Master
1233 -- Nothing to do if the circumstances do not allow for a finalization
1236 if not Allows_Finalization_Master
(Typ
) then
1239 -- Various machinery such as freezing may have already created a
1240 -- finalization master.
1242 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1247 Actions
: constant List_Id
:= New_List
;
1248 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1249 Fin_Mas_Id
: Entity_Id
;
1250 Pool_Id
: Entity_Id
;
1253 -- Source access types use fixed master names since the master is
1254 -- inserted in the same source unit only once. The only exception to
1255 -- this are instances using the same access type as generic actual.
1257 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1259 Make_Defining_Identifier
(Loc
,
1260 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1262 -- Internally generated access types use temporaries as their names
1263 -- due to possible collision with identical names coming from other
1267 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1270 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1273 -- <Ptr_Typ>FM : aliased Finalization_Master;
1276 Make_Object_Declaration
(Loc
,
1277 Defining_Identifier
=> Fin_Mas_Id
,
1278 Aliased_Present
=> True,
1279 Object_Definition
=>
1280 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1282 if Debug_Generated_Code
then
1283 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1286 -- Set the associated pool and primitive Finalize_Address of the new
1287 -- finalization master.
1289 -- The access type has a user-defined storage pool, use it
1291 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1292 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1294 -- Otherwise the default choice is the global storage pool
1297 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1298 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1302 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1305 Make_Procedure_Call_Statement
(Loc
,
1307 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1308 Parameter_Associations
=> New_List
(
1309 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1310 Make_Attribute_Reference
(Loc
,
1311 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1312 Attribute_Name
=> Name_Unrestricted_Access
))));
1314 -- Finalize_Address is not generated in CodePeer mode because the
1315 -- body contains address arithmetic. Skip this step.
1317 if CodePeer_Mode
then
1320 -- Associate the Finalize_Address primitive of the designated type
1321 -- with the finalization master of the access type. The designated
1322 -- type must be forzen as Finalize_Address is generated when the
1323 -- freeze node is expanded.
1325 elsif Is_Frozen
(Desig_Typ
)
1326 and then Present
(Finalize_Address
(Desig_Typ
))
1328 -- The finalization master of an anonymous access type may need
1329 -- to be inserted in a specific place in the tree. For instance:
1333 -- <finalization master of "access Comp_Typ">
1335 -- type Rec_Typ is record
1336 -- Comp : access Comp_Typ;
1339 -- <freeze node for Comp_Typ>
1340 -- <freeze node for Rec_Typ>
1342 -- Due to this oddity, the anonymous access type is stored for
1343 -- later processing (see below).
1345 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1348 -- Set_Finalize_Address
1349 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1352 Make_Set_Finalize_Address_Call
1354 Ptr_Typ
=> Ptr_Typ
));
1356 -- Otherwise the designated type is either anonymous access or a
1357 -- Taft-amendment type and has not been frozen. Store the access
1358 -- type for later processing (see Freeze_Type).
1361 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1364 -- A finalization master created for an access designating a type
1365 -- with private components is inserted before a context-dependent
1370 -- At this point both the scope of the context and the insertion
1371 -- mode must be known.
1373 pragma Assert
(Present
(Context_Scope
));
1374 pragma Assert
(Present
(Insertion_Node
));
1376 Push_Scope
(Context_Scope
);
1378 -- Treat use clauses as declarations and insert directly in front
1381 if Nkind
(Insertion_Node
) in
1382 N_Use_Package_Clause | N_Use_Type_Clause
1384 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1386 Insert_Actions
(Insertion_Node
, Actions
);
1391 -- The finalization master belongs to an access result type related
1392 -- to a build-in-place function call used to initialize a library
1393 -- level object. The master must be inserted in front of the access
1394 -- result type declaration denoted by Insertion_Node.
1396 elsif For_Lib_Level
then
1397 pragma Assert
(Present
(Insertion_Node
));
1398 Insert_Actions
(Insertion_Node
, Actions
);
1400 -- Otherwise the finalization master and its initialization become a
1401 -- part of the freeze node.
1404 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1407 Analyze_List
(Actions
);
1409 -- When the type the finalization master is being generated for was
1410 -- created to store a 'Old object, then mark it as such so its
1411 -- finalization can be delayed until after postconditions have been
1414 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1415 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1418 end Build_Finalization_Master
;
1420 ----------------------------
1421 -- Build_Finalizer_Helper --
1422 ----------------------------
1424 procedure Build_Finalizer_Helper
1426 Clean_Stmts
: List_Id
;
1427 Mark_Id
: Entity_Id
;
1428 Top_Decls
: List_Id
;
1429 Defer_Abort
: Boolean;
1430 Fin_Id
: out Entity_Id
;
1431 Finalize_Old_Only
: Boolean)
1433 Acts_As_Clean
: constant Boolean :=
1436 (Present
(Clean_Stmts
)
1437 and then Is_Non_Empty_List
(Clean_Stmts
));
1439 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1440 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1441 For_Package
: constant Boolean :=
1442 For_Package_Body
or else For_Package_Spec
;
1443 Loc
: constant Source_Ptr
:= Sloc
(N
);
1445 -- NOTE: Local variable declarations are conservative and do not create
1446 -- structures right from the start. Entities and lists are created once
1447 -- it has been established that N has at least one controlled object.
1449 Components_Built
: Boolean := False;
1450 -- A flag used to avoid double initialization of entities and lists. If
1451 -- the flag is set then the following variables have been initialized:
1457 Counter_Id
: Entity_Id
:= Empty
;
1458 Counter_Val
: Nat
:= 0;
1459 -- Name and value of the state counter
1461 Decls
: List_Id
:= No_List
;
1462 -- Declarative region of N (if available). If N is a package declaration
1463 -- Decls denotes the visible declarations.
1465 Finalizer_Data
: Finalization_Exception_Data
;
1466 -- Data for the exception
1468 Finalizer_Decls
: List_Id
:= No_List
;
1469 -- Local variable declarations. This list holds the label declarations
1470 -- of all jump block alternatives as well as the declaration of the
1471 -- local exception occurrence and the raised flag:
1472 -- E : Exception_Occurrence;
1473 -- Raised : Boolean := False;
1474 -- L<counter value> : label;
1476 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1477 -- Insertion point for the finalizer body. Depending on the context
1478 -- (Nkind of N) and the individual grouping of controlled objects, this
1479 -- node may denote a package declaration or body, package instantiation,
1480 -- block statement or a counter update statement.
1482 Finalizer_Stmts
: List_Id
:= No_List
;
1483 -- The statement list of the finalizer body. It contains the following:
1485 -- Abort_Defer; -- Added if abort is allowed
1486 -- <call to Prev_At_End> -- Added if exists
1487 -- <cleanup statements> -- Added if Acts_As_Clean
1488 -- <jump block> -- Added if Has_Ctrl_Objs
1489 -- <finalization statements> -- Added if Has_Ctrl_Objs
1490 -- <stack release> -- Added if Mark_Id exists
1491 -- Abort_Undefer; -- Added if abort is allowed
1493 Has_Ctrl_Objs
: Boolean := False;
1494 -- A general flag which denotes whether N has at least one controlled
1497 Has_Tagged_Types
: Boolean := False;
1498 -- A general flag which indicates whether N has at least one library-
1499 -- level tagged type declaration.
1501 HSS
: Node_Id
:= Empty
;
1502 -- The sequence of statements of N (if available)
1504 Jump_Alts
: List_Id
:= No_List
;
1505 -- Jump block alternatives. Depending on the value of the state counter,
1506 -- the control flow jumps to a sequence of finalization statements. This
1507 -- list contains the following:
1509 -- when <counter value> =>
1510 -- goto L<counter value>;
1512 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1513 -- Specific point in the finalizer statements where the jump block is
1516 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1517 -- The last controlled construct encountered when processing the top
1518 -- level lists of N. This can be a nested package, an instantiation or
1519 -- an object declaration.
1521 Prev_At_End
: Entity_Id
:= Empty
;
1522 -- The previous at end procedure of the handled statements block of N
1524 Priv_Decls
: List_Id
:= No_List
;
1525 -- The private declarations of N if N is a package declaration
1527 Spec_Id
: Entity_Id
:= Empty
;
1528 Spec_Decls
: List_Id
:= Top_Decls
;
1529 Stmts
: List_Id
:= No_List
;
1531 Tagged_Type_Stmts
: List_Id
:= No_List
;
1532 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1533 -- tagged types found in N.
1535 -----------------------
1536 -- Local subprograms --
1537 -----------------------
1539 procedure Build_Components
;
1540 -- Create all entites and initialize all lists used in the creation of
1543 procedure Create_Finalizer
;
1544 -- Create the spec and body of the finalizer and insert them in the
1545 -- proper place in the tree depending on the context.
1547 function New_Finalizer_Name
1548 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1549 -- Create a fully qualified name of a package spec or body finalizer.
1550 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1552 procedure Process_Declarations
1554 Preprocess
: Boolean := False;
1555 Top_Level
: Boolean := False);
1556 -- Inspect a list of declarations or statements which may contain
1557 -- objects that need finalization. When flag Preprocess is set, the
1558 -- routine will simply count the total number of controlled objects in
1559 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1560 -- when Preprocess is set and if True, the processing is performed for
1561 -- objects in nested package declarations or instances.
1563 procedure Process_Object_Declaration
1565 Has_No_Init
: Boolean := False;
1566 Is_Protected
: Boolean := False);
1567 -- Generate all the machinery associated with the finalization of a
1568 -- single object. Flag Has_No_Init is used to denote certain contexts
1569 -- where Decl does not have initialization call(s). Flag Is_Protected
1570 -- is set when Decl denotes a simple protected object.
1572 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1573 -- Generate all the code necessary to unregister the external tag of a
1576 ----------------------
1577 -- Build_Components --
1578 ----------------------
1580 procedure Build_Components
is
1581 Counter_Decl
: Node_Id
;
1582 Counter_Typ
: Entity_Id
;
1583 Counter_Typ_Decl
: Node_Id
;
1586 pragma Assert
(Present
(Decls
));
1588 -- This routine might be invoked several times when dealing with
1589 -- constructs that have two lists (either two declarative regions
1590 -- or declarations and statements). Avoid double initialization.
1592 if Components_Built
then
1596 Components_Built
:= True;
1598 if Has_Ctrl_Objs
then
1600 -- Create entities for the counter, its type, the local exception
1601 -- and the raised flag.
1603 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1604 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1606 Finalizer_Decls
:= New_List
;
1608 Build_Object_Declarations
1609 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1611 -- Since the total number of controlled objects is always known,
1612 -- build a subtype of Natural with precise bounds. This allows
1613 -- the backend to optimize the case statement. Generate:
1615 -- subtype Tnn is Natural range 0 .. Counter_Val;
1618 Make_Subtype_Declaration
(Loc
,
1619 Defining_Identifier
=> Counter_Typ
,
1620 Subtype_Indication
=>
1621 Make_Subtype_Indication
(Loc
,
1622 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1624 Make_Range_Constraint
(Loc
,
1628 Make_Integer_Literal
(Loc
, Uint_0
),
1630 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1632 -- Generate the declaration of the counter itself:
1634 -- Counter : Integer := 0;
1637 Make_Object_Declaration
(Loc
,
1638 Defining_Identifier
=> Counter_Id
,
1639 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1640 Expression
=> Make_Integer_Literal
(Loc
, 0));
1642 -- Set the type of the counter explicitly to prevent errors when
1643 -- examining object declarations later on.
1645 Set_Etype
(Counter_Id
, Counter_Typ
);
1647 if Debug_Generated_Code
then
1648 Set_Debug_Info_Needed
(Counter_Id
);
1651 -- The counter and its type are inserted before the source
1652 -- declarations of N.
1654 Prepend_To
(Decls
, Counter_Decl
);
1655 Prepend_To
(Decls
, Counter_Typ_Decl
);
1657 -- The counter and its associated type must be manually analyzed
1658 -- since N has already been analyzed. Use the scope of the spec
1659 -- when inserting in a package.
1662 Push_Scope
(Spec_Id
);
1663 Analyze
(Counter_Typ_Decl
);
1664 Analyze
(Counter_Decl
);
1668 Analyze
(Counter_Typ_Decl
);
1669 Analyze
(Counter_Decl
);
1672 Jump_Alts
:= New_List
;
1675 -- If the context requires additional cleanup, the finalization
1676 -- machinery is added after the cleanup code.
1678 if Acts_As_Clean
then
1679 Finalizer_Stmts
:= Clean_Stmts
;
1680 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1682 Finalizer_Stmts
:= New_List
;
1685 if Has_Tagged_Types
then
1686 Tagged_Type_Stmts
:= New_List
;
1688 end Build_Components
;
1690 ----------------------
1691 -- Create_Finalizer --
1692 ----------------------
1694 procedure Create_Finalizer
is
1695 Body_Id
: Entity_Id
;
1698 Jump_Block
: Node_Id
;
1700 Label_Id
: Entity_Id
;
1703 -- Step 1: Creation of the finalizer name
1705 -- Packages must use a distinct name for their finalizers since the
1706 -- binder will have to generate calls to them by name. The name is
1707 -- of the following form:
1709 -- xx__yy__finalize_[spec|body]
1712 Fin_Id
:= Make_Defining_Identifier
1713 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1714 Set_Has_Qualified_Name
(Fin_Id
);
1715 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1717 -- The default name is _finalizer
1720 -- Generation of a finalization procedure exclusively for 'Old
1721 -- interally generated constants requires different name since
1722 -- there will need to be multiple finalization routines in the
1723 -- same scope. See Build_Finalizer for details.
1725 if Finalize_Old_Only
then
1727 Make_Defining_Identifier
(Loc
,
1728 Chars
=> New_External_Name
(Name_uFinalizer_Old
));
1731 Make_Defining_Identifier
(Loc
,
1732 Chars
=> New_External_Name
(Name_uFinalizer
));
1735 -- The visibility semantics of AT_END handlers force a strange
1736 -- separation of spec and body for stack-related finalizers:
1738 -- declare : Enclosing_Scope
1739 -- procedure _finalizer;
1741 -- <controlled objects>
1742 -- procedure _finalizer is
1748 -- Both spec and body are within the same construct and scope, but
1749 -- the body is part of the handled sequence of statements. This
1750 -- placement confuses the elaboration mechanism on targets where
1751 -- AT_END handlers are expanded into "when all others" handlers:
1754 -- when all others =>
1755 -- _finalizer; -- appears to require elab checks
1760 -- Since the compiler guarantees that the body of a _finalizer is
1761 -- always inserted in the same construct where the AT_END handler
1762 -- resides, there is no need for elaboration checks.
1764 Set_Kill_Elaboration_Checks
(Fin_Id
);
1766 -- Inlining the finalizer produces a substantial speedup at -O2.
1767 -- It is inlined by default at -O3. Either way, it is called
1768 -- exactly twice (once on the normal path, and once for
1769 -- exceptions/abort), so this won't bloat the code too much.
1771 Set_Is_Inlined
(Fin_Id
);
1774 if Debug_Generated_Code
then
1775 Set_Debug_Info_Needed
(Fin_Id
);
1778 -- Step 2: Creation of the finalizer specification
1781 -- procedure Fin_Id;
1784 Make_Subprogram_Declaration
(Loc
,
1786 Make_Procedure_Specification
(Loc
,
1787 Defining_Unit_Name
=> Fin_Id
));
1790 Set_Is_Exported
(Fin_Id
);
1791 Set_Interface_Name
(Fin_Id
,
1792 Make_String_Literal
(Loc
,
1793 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1796 -- Step 3: Creation of the finalizer body
1798 -- Has_Ctrl_Objs might be set because of a generic package body having
1799 -- controlled objects. In this case, Jump_Alts may be empty and no
1800 -- case nor goto statements are needed.
1803 and then not Is_Empty_List
(Jump_Alts
)
1805 -- Add L0, the default destination to the jump block
1807 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1808 Set_Entity
(Label_Id
,
1809 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1810 Label
:= Make_Label
(Loc
, Label_Id
);
1815 Prepend_To
(Finalizer_Decls
,
1816 Make_Implicit_Label_Declaration
(Loc
,
1817 Defining_Identifier
=> Entity
(Label_Id
),
1818 Label_Construct
=> Label
));
1824 Append_To
(Jump_Alts
,
1825 Make_Case_Statement_Alternative
(Loc
,
1826 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1827 Statements
=> New_List
(
1828 Make_Goto_Statement
(Loc
,
1829 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1834 Append_To
(Finalizer_Stmts
, Label
);
1836 -- Create the jump block which controls the finalization flow
1837 -- depending on the value of the state counter.
1840 Make_Case_Statement
(Loc
,
1841 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1842 Alternatives
=> Jump_Alts
);
1844 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1845 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1847 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1851 -- Add the library-level tagged type unregistration machinery before
1852 -- the jump block circuitry. This ensures that external tags will be
1853 -- removed even if a finalization exception occurs at some point.
1855 if Has_Tagged_Types
then
1856 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1859 -- Add a call to the previous At_End handler if it exists. The call
1860 -- must always precede the jump block.
1862 if Present
(Prev_At_End
) then
1863 Prepend_To
(Finalizer_Stmts
,
1864 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1866 -- Clear the At_End handler since we have already generated the
1867 -- proper replacement call for it.
1869 Set_At_End_Proc
(HSS
, Empty
);
1872 -- Release the secondary stack
1874 if Present
(Mark_Id
) then
1876 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1879 -- If the context is a build-in-place function, the secondary
1880 -- stack must be released, unless the build-in-place function
1881 -- itself is returning on the secondary stack. Generate:
1883 -- if BIP_Alloc_Form /= Secondary_Stack then
1884 -- SS_Release (Mark_Id);
1887 -- Note that if the function returns on the secondary stack,
1888 -- then the responsibility of reclaiming the space is always
1889 -- left to the caller (recursively if needed).
1891 if Nkind
(N
) = N_Subprogram_Body
then
1893 Spec_Id
: constant Entity_Id
:=
1894 Unique_Defining_Entity
(N
);
1895 BIP_SS
: constant Boolean :=
1896 Is_Build_In_Place_Function
(Spec_Id
)
1897 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1901 Make_If_Statement
(Loc
,
1906 (Build_In_Place_Formal
1907 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1909 Make_Integer_Literal
(Loc
,
1911 (BIP_Allocation_Form
'Pos
1912 (Secondary_Stack
)))),
1914 Then_Statements
=> New_List
(Release
));
1919 Append_To
(Finalizer_Stmts
, Release
);
1923 -- Protect the statements with abort defer/undefer. This is only when
1924 -- aborts are allowed and the cleanup statements require deferral or
1925 -- there are controlled objects to be finalized. Note that the abort
1926 -- defer/undefer pair does not require an extra block because each
1927 -- finalization exception is caught in its corresponding finalization
1928 -- block. As a result, the call to Abort_Defer always takes place.
1930 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1931 Prepend_To
(Finalizer_Stmts
,
1932 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1934 Append_To
(Finalizer_Stmts
,
1935 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1938 -- The local exception does not need to be reraised for library-level
1939 -- finalizers. Note that this action must be carried out after object
1940 -- cleanup, secondary stack release, and abort undeferral. Generate:
1942 -- if Raised and then not Abort then
1943 -- Raise_From_Controlled_Operation (E);
1946 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1947 Append_To
(Finalizer_Stmts
,
1948 Build_Raise_Statement
(Finalizer_Data
));
1952 -- procedure Fin_Id is
1953 -- Abort : constant Boolean := Triggered_By_Abort;
1955 -- Abort : constant Boolean := False; -- no abort
1957 -- E : Exception_Occurrence; -- All added if flag
1958 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1964 -- Abort_Defer; -- Added if abort is allowed
1965 -- <call to Prev_At_End> -- Added if exists
1966 -- <cleanup statements> -- Added if Acts_As_Clean
1967 -- <jump block> -- Added if Has_Ctrl_Objs
1968 -- <finalization statements> -- Added if Has_Ctrl_Objs
1969 -- <stack release> -- Added if Mark_Id exists
1970 -- Abort_Undefer; -- Added if abort is allowed
1971 -- <exception propagation> -- Added if Has_Ctrl_Objs
1974 -- Create the body of the finalizer
1976 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1978 if Debug_Generated_Code
then
1979 Set_Debug_Info_Needed
(Body_Id
);
1983 Set_Has_Qualified_Name
(Body_Id
);
1984 Set_Has_Fully_Qualified_Name
(Body_Id
);
1988 Make_Subprogram_Body
(Loc
,
1990 Make_Procedure_Specification
(Loc
,
1991 Defining_Unit_Name
=> Body_Id
),
1992 Declarations
=> Finalizer_Decls
,
1993 Handled_Statement_Sequence
=>
1994 Make_Handled_Sequence_Of_Statements
(Loc
,
1995 Statements
=> Finalizer_Stmts
));
1997 -- Step 4: Spec and body insertion, analysis
2001 -- If the package spec has private declarations, the finalizer
2002 -- body must be added to the end of the list in order to have
2003 -- visibility of all private controlled objects.
2005 if For_Package_Spec
then
2006 if Present
(Priv_Decls
) then
2007 Append_To
(Priv_Decls
, Fin_Spec
);
2008 Append_To
(Priv_Decls
, Fin_Body
);
2010 Append_To
(Decls
, Fin_Spec
);
2011 Append_To
(Decls
, Fin_Body
);
2014 -- For package bodies, both the finalizer spec and body are
2015 -- inserted at the end of the package declarations.
2018 Append_To
(Decls
, Fin_Spec
);
2019 Append_To
(Decls
, Fin_Body
);
2022 -- Push the name of the package
2024 Push_Scope
(Spec_Id
);
2032 -- Create the spec for the finalizer. The At_End handler must be
2033 -- able to call the body which resides in a nested structure.
2037 -- procedure Fin_Id; -- Spec
2039 -- <objects and possibly statements>
2040 -- procedure Fin_Id is ... -- Body
2043 -- Fin_Id; -- At_End handler
2046 pragma Assert
(Present
(Spec_Decls
));
2048 -- It maybe possible that we are finalizing 'Old objects which
2049 -- exist in the spec declarations. When this is the case the
2050 -- Finalizer_Insert_Node will come before the end of the
2051 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
2052 -- earlier at the Finalizer_Insert_Nod instead of appending to the
2053 -- end of Spec_Decls to prevent its body appearing before its
2054 -- corresponding spec.
2056 if Present
(Finalizer_Insert_Nod
)
2057 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
2059 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
2060 Finalizer_Insert_Nod
:= Fin_Spec
;
2062 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
2065 Append_To
(Spec_Decls
, Fin_Spec
);
2069 -- When the finalizer acts solely as a cleanup routine, the body
2070 -- is inserted right after the spec.
2072 if Acts_As_Clean
and not Has_Ctrl_Objs
then
2073 Insert_After
(Fin_Spec
, Fin_Body
);
2075 -- In all other cases the body is inserted after either:
2077 -- 1) The counter update statement of the last controlled object
2078 -- 2) The last top level nested controlled package
2079 -- 3) The last top level controlled instantiation
2082 -- Manually freeze the spec. This is somewhat of a hack because
2083 -- a subprogram is frozen when its body is seen and the freeze
2084 -- node appears right before the body. However, in this case,
2085 -- the spec must be frozen earlier since the At_End handler
2086 -- must be able to call it.
2089 -- procedure Fin_Id; -- Spec
2090 -- [Fin_Id] -- Freeze node
2094 -- Fin_Id; -- At_End handler
2097 Ensure_Freeze_Node
(Fin_Id
);
2098 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2099 Set_Is_Frozen
(Fin_Id
);
2101 -- In the case where the last construct to contain a controlled
2102 -- object is either a nested package, an instantiation or a
2103 -- freeze node, the body must be inserted directly after the
2106 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2107 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2109 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2112 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2115 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2118 -- Never consider that the finalizer procedure is enabled Ghost, even
2119 -- when the corresponding unit is Ghost, as this would lead to an
2120 -- an external name with a ___ghost_ prefix that the binder cannot
2121 -- generate, as it has no knowledge of the Ghost status of units.
2123 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2124 end Create_Finalizer
;
2126 ------------------------
2127 -- New_Finalizer_Name --
2128 ------------------------
2130 function New_Finalizer_Name
2131 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2133 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2134 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2135 -- has a non-standard scope, process the scope first.
2137 ------------------------
2138 -- New_Finalizer_Name --
2139 ------------------------
2141 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2143 if Scope
(Id
) = Standard_Standard
then
2144 Get_Name_String
(Chars
(Id
));
2147 New_Finalizer_Name
(Scope
(Id
));
2148 Add_Str_To_Name_Buffer
("__");
2149 Get_Name_String_And_Append
(Chars
(Id
));
2151 end New_Finalizer_Name
;
2153 -- Start of processing for New_Finalizer_Name
2156 -- Create the fully qualified name of the enclosing scope
2158 New_Finalizer_Name
(Spec_Id
);
2161 -- __finalize_[spec|body]
2163 Add_Str_To_Name_Buffer
("__finalize_");
2166 Add_Str_To_Name_Buffer
("spec");
2168 Add_Str_To_Name_Buffer
("body");
2172 end New_Finalizer_Name
;
2174 --------------------------
2175 -- Process_Declarations --
2176 --------------------------
2178 procedure Process_Declarations
2180 Preprocess
: Boolean := False;
2181 Top_Level
: Boolean := False)
2186 Obj_Typ
: Entity_Id
;
2187 Pack_Id
: Entity_Id
;
2191 Old_Counter_Val
: Nat
;
2192 -- This variable is used to determine whether a nested package or
2193 -- instance contains at least one controlled object.
2195 procedure Processing_Actions
2196 (Has_No_Init
: Boolean := False;
2197 Is_Protected
: Boolean := False);
2198 -- Depending on the mode of operation of Process_Declarations, either
2199 -- increment the controlled object counter, set the controlled object
2200 -- flag and store the last top level construct or process the current
2201 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2202 -- the current declaration may not have initialization proc(s). Flag
2203 -- Is_Protected should be set when the current declaration denotes a
2204 -- simple protected object.
2206 ------------------------
2207 -- Processing_Actions --
2208 ------------------------
2210 procedure Processing_Actions
2211 (Has_No_Init
: Boolean := False;
2212 Is_Protected
: Boolean := False)
2215 -- Library-level tagged type
2217 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2219 Has_Tagged_Types
:= True;
2221 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2222 Last_Top_Level_Ctrl_Construct
:= Decl
;
2226 Process_Tagged_Type_Declaration
(Decl
);
2229 -- Controlled object declaration
2233 Counter_Val
:= Counter_Val
+ 1;
2234 Has_Ctrl_Objs
:= True;
2236 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2237 Last_Top_Level_Ctrl_Construct
:= Decl
;
2241 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2244 end Processing_Actions
;
2246 -- Start of processing for Process_Declarations
2249 if No
(Decls
) or else Is_Empty_List
(Decls
) then
2253 -- Process all declarations in reverse order
2255 Decl
:= Last_Non_Pragma
(Decls
);
2256 while Present
(Decl
) loop
2257 -- Depending on the value of flag Finalize_Old_Only we determine
2258 -- which objects get finalized as part of the current finalizer
2261 -- When True, only temporaries capturing the value of attribute
2262 -- 'Old are finalized and all other cases are ignored.
2264 -- When False, temporary objects used to capture the value of 'Old
2265 -- are ignored and all others are considered.
2267 if Finalize_Old_Only
2268 xor (Nkind
(Decl
) = N_Object_Declaration
2269 and then Stores_Attribute_Old_Prefix
2270 (Defining_Identifier
(Decl
)))
2274 -- Library-level tagged types
2276 elsif Nkind
(Decl
) = N_Full_Type_Declaration
then
2277 Typ
:= Defining_Identifier
(Decl
);
2279 -- Ignored Ghost types do not need any cleanup actions because
2280 -- they will not appear in the final tree.
2282 if Is_Ignored_Ghost_Entity
(Typ
) then
2285 elsif Is_Tagged_Type
(Typ
)
2286 and then Is_Library_Level_Entity
(Typ
)
2287 and then Convention
(Typ
) = Convention_Ada
2288 and then Present
(Access_Disp_Table
(Typ
))
2289 and then RTE_Available
(RE_Register_Tag
)
2290 and then not Is_Abstract_Type
(Typ
)
2291 and then not No_Run_Time_Mode
2296 -- Regular object declarations
2298 elsif Nkind
(Decl
) = N_Object_Declaration
then
2299 Obj_Id
:= Defining_Identifier
(Decl
);
2300 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2301 Expr
:= Expression
(Decl
);
2303 -- Bypass any form of processing for objects which have their
2304 -- finalization disabled. This applies only to objects at the
2307 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2310 -- Finalization of transient objects are treated separately in
2311 -- order to handle sensitive cases. These include:
2313 -- * Aggregate expansion
2314 -- * If, case, and expression with actions expansion
2315 -- * Transient scopes
2317 -- If one of those contexts has marked the transient object as
2318 -- ignored, do not generate finalization actions for it.
2320 elsif Is_Finalized_Transient
(Obj_Id
)
2321 or else Is_Ignored_Transient
(Obj_Id
)
2325 -- Ignored Ghost objects do not need any cleanup actions
2326 -- because they will not appear in the final tree.
2328 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2331 -- The object is of the form:
2332 -- Obj : [constant] Typ [:= Expr];
2334 -- Do not process tag-to-class-wide conversions because they do
2335 -- not yield an object. Do not process the incomplete view of a
2336 -- deferred constant. Note that an object initialized by means
2337 -- of a build-in-place function call may appear as a deferred
2338 -- constant after expansion activities. These kinds of objects
2339 -- must be finalized.
2341 elsif not Is_Imported
(Obj_Id
)
2342 and then Needs_Finalization
(Obj_Typ
)
2343 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2344 and then not (Ekind
(Obj_Id
) = E_Constant
2345 and then not Has_Completion
(Obj_Id
)
2346 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2350 -- The object is of the form:
2351 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2353 -- Obj : Access_Typ :=
2354 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2356 elsif Is_Access_Type
(Obj_Typ
)
2357 and then Needs_Finalization
2358 (Available_View
(Designated_Type
(Obj_Typ
)))
2359 and then Present
(Expr
)
2361 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2363 (Is_Non_BIP_Func_Call
(Expr
)
2364 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2366 Processing_Actions
(Has_No_Init
=> True);
2368 -- Processing for "hook" objects generated for transient
2369 -- objects declared inside an Expression_With_Actions.
2371 elsif Is_Access_Type
(Obj_Typ
)
2372 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2373 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2374 N_Object_Declaration
2376 Processing_Actions
(Has_No_Init
=> True);
2378 -- Process intermediate results of an if expression with one
2379 -- of the alternatives using a controlled function call.
2381 elsif Is_Access_Type
(Obj_Typ
)
2382 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2383 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2384 N_Defining_Identifier
2385 and then Present
(Expr
)
2386 and then Nkind
(Expr
) = N_Null
2388 Processing_Actions
(Has_No_Init
=> True);
2390 -- Simple protected objects which use type System.Tasking.
2391 -- Protected_Objects.Protection to manage their locks should
2392 -- be treated as controlled since they require manual cleanup.
2393 -- The only exception is illustrated in the following example:
2396 -- type Ctrl is new Controlled ...
2397 -- procedure Finalize (Obj : in out Ctrl);
2401 -- package body Pkg is
2402 -- protected Prot is
2403 -- procedure Do_Something (Obj : in out Ctrl);
2406 -- protected body Prot is
2407 -- procedure Do_Something (Obj : in out Ctrl) is ...
2410 -- procedure Finalize (Obj : in out Ctrl) is
2412 -- Prot.Do_Something (Obj);
2416 -- Since for the most part entities in package bodies depend on
2417 -- those in package specs, Prot's lock should be cleaned up
2418 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2419 -- This act however attempts to invoke Do_Something and fails
2420 -- because the lock has disappeared.
2422 elsif Ekind
(Obj_Id
) = E_Variable
2423 and then not In_Library_Level_Package_Body
(Obj_Id
)
2424 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2425 or else Has_Simple_Protected_Object
(Obj_Typ
))
2427 Processing_Actions
(Is_Protected
=> True);
2430 -- Specific cases of object renamings
2432 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2433 Obj_Id
:= Defining_Identifier
(Decl
);
2434 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2436 -- Bypass any form of processing for objects which have their
2437 -- finalization disabled. This applies only to objects at the
2440 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2443 -- Ignored Ghost object renamings do not need any cleanup
2444 -- actions because they will not appear in the final tree.
2446 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2449 -- Return object of a build-in-place function. This case is
2450 -- recognized and marked by the expansion of an extended return
2451 -- statement (see Expand_N_Extended_Return_Statement).
2453 elsif Needs_Finalization
(Obj_Typ
)
2454 and then Is_Return_Object
(Obj_Id
)
2455 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2457 Processing_Actions
(Has_No_Init
=> True);
2459 -- Detect a case where a source object has been initialized by
2460 -- a controlled function call or another object which was later
2461 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2463 -- Obj1 : CW_Type := Src_Obj;
2464 -- Obj2 : CW_Type := Function_Call (...);
2466 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2467 -- Tmp : ... := Function_Call (...)'reference;
2468 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2470 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2471 Processing_Actions
(Has_No_Init
=> True);
2474 -- Inspect the freeze node of an access-to-controlled type and
2475 -- look for a delayed finalization master. This case arises when
2476 -- the freeze actions are inserted at a later time than the
2477 -- expansion of the context. Since Build_Finalizer is never called
2478 -- on a single construct twice, the master will be ultimately
2479 -- left out and never finalized. This is also needed for freeze
2480 -- actions of designated types themselves, since in some cases the
2481 -- finalization master is associated with a designated type's
2482 -- freeze node rather than that of the access type (see handling
2483 -- for freeze actions in Build_Finalization_Master).
2485 elsif Nkind
(Decl
) = N_Freeze_Entity
2486 and then Present
(Actions
(Decl
))
2488 Typ
:= Entity
(Decl
);
2490 -- Freeze nodes for ignored Ghost types do not need cleanup
2491 -- actions because they will never appear in the final tree.
2493 if Is_Ignored_Ghost_Entity
(Typ
) then
2496 elsif (Is_Access_Object_Type
(Typ
)
2497 and then Needs_Finalization
2498 (Available_View
(Designated_Type
(Typ
))))
2499 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2501 Old_Counter_Val
:= Counter_Val
;
2503 -- Freeze nodes are considered to be identical to packages
2504 -- and blocks in terms of nesting. The difference is that
2505 -- a finalization master created inside the freeze node is
2506 -- at the same nesting level as the node itself.
2508 Process_Declarations
(Actions
(Decl
), Preprocess
);
2510 -- The freeze node contains a finalization master
2514 and then No
(Last_Top_Level_Ctrl_Construct
)
2515 and then Counter_Val
> Old_Counter_Val
2517 Last_Top_Level_Ctrl_Construct
:= Decl
;
2521 -- Nested package declarations, avoid generics
2523 elsif Nkind
(Decl
) = N_Package_Declaration
then
2524 Pack_Id
:= Defining_Entity
(Decl
);
2525 Spec
:= Specification
(Decl
);
2527 -- Do not inspect an ignored Ghost package because all code
2528 -- found within will not appear in the final tree.
2530 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2533 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2534 Old_Counter_Val
:= Counter_Val
;
2535 Process_Declarations
2536 (Private_Declarations
(Spec
), Preprocess
);
2537 Process_Declarations
2538 (Visible_Declarations
(Spec
), Preprocess
);
2540 -- Either the visible or the private declarations contain a
2541 -- controlled object. The nested package declaration is the
2542 -- last such construct.
2546 and then No
(Last_Top_Level_Ctrl_Construct
)
2547 and then Counter_Val
> Old_Counter_Val
2549 Last_Top_Level_Ctrl_Construct
:= Decl
;
2553 -- Call the xxx__finalize_body procedure of a library level
2554 -- package instantiation if the body contains finalization
2557 if Present
(Generic_Parent
(Spec
))
2558 and then Is_Library_Level_Entity
(Pack_Id
)
2559 and then Present
(Body_Entity
(Generic_Parent
(Spec
)))
2565 P
:= Parent
(Body_Entity
(Generic_Parent
(Spec
)));
2567 and then Nkind
(P
) /= N_Package_Body
2573 Old_Counter_Val
:= Counter_Val
;
2574 Process_Declarations
(Declarations
(P
), Preprocess
);
2576 -- Note that we are processing the generic body
2577 -- template and not the actually instantiation
2578 -- (which is generated too late for us to process
2579 -- it), so there is no need to update in particular
2580 -- to update Last_Top_Level_Ctrl_Construct here.
2582 if Counter_Val
> Old_Counter_Val
then
2583 Counter_Val
:= Old_Counter_Val
;
2584 Set_Has_Controlled_Component
(Pack_Id
);
2589 elsif Has_Controlled_Component
(Pack_Id
) then
2591 -- We import the xxx__finalize_body routine since the
2592 -- generic body will be instantiated later.
2595 Id
: constant Node_Id
:=
2596 Make_Defining_Identifier
(Loc
,
2597 New_Finalizer_Name
(Defining_Unit_Name
(Spec
),
2598 For_Spec
=> False));
2601 Set_Has_Qualified_Name
(Id
);
2602 Set_Has_Fully_Qualified_Name
(Id
);
2603 Set_Is_Imported
(Id
);
2604 Set_Has_Completion
(Id
);
2605 Set_Interface_Name
(Id
,
2606 Make_String_Literal
(Loc
,
2607 Strval
=> Get_Name_String
(Chars
(Id
))));
2609 Append_New_To
(Finalizer_Stmts
,
2610 Make_Subprogram_Declaration
(Loc
,
2611 Make_Procedure_Specification
(Loc
,
2612 Defining_Unit_Name
=> Id
)));
2613 Append_To
(Finalizer_Stmts
,
2614 Make_Procedure_Call_Statement
(Loc
,
2615 Name
=> New_Occurrence_Of
(Id
, Loc
)));
2620 -- Nested package bodies, avoid generics
2622 elsif Nkind
(Decl
) = N_Package_Body
then
2624 -- Do not inspect an ignored Ghost package body because all
2625 -- code found within will not appear in the final tree.
2627 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2630 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
2632 Old_Counter_Val
:= Counter_Val
;
2633 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2635 -- The nested package body is the last construct to contain
2636 -- a controlled object.
2640 and then No
(Last_Top_Level_Ctrl_Construct
)
2641 and then Counter_Val
> Old_Counter_Val
2643 Last_Top_Level_Ctrl_Construct
:= Decl
;
2647 -- Handle a rare case caused by a controlled transient object
2648 -- created as part of a record init proc. The variable is wrapped
2649 -- in a block, but the block is not associated with a transient
2652 elsif Nkind
(Decl
) = N_Block_Statement
2653 and then Inside_Init_Proc
2655 Old_Counter_Val
:= Counter_Val
;
2657 if Present
(Handled_Statement_Sequence
(Decl
)) then
2658 Process_Declarations
2659 (Statements
(Handled_Statement_Sequence
(Decl
)),
2663 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2665 -- Either the declaration or statement list of the block has a
2666 -- controlled object.
2670 and then No
(Last_Top_Level_Ctrl_Construct
)
2671 and then Counter_Val
> Old_Counter_Val
2673 Last_Top_Level_Ctrl_Construct
:= Decl
;
2676 -- Handle the case where the original context has been wrapped in
2677 -- a block to avoid interference between exception handlers and
2678 -- At_End handlers. Treat the block as transparent and process its
2681 elsif Nkind
(Decl
) = N_Block_Statement
2682 and then Is_Finalization_Wrapper
(Decl
)
2684 if Present
(Handled_Statement_Sequence
(Decl
)) then
2685 Process_Declarations
2686 (Statements
(Handled_Statement_Sequence
(Decl
)),
2690 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2693 Prev_Non_Pragma
(Decl
);
2695 end Process_Declarations
;
2697 --------------------------------
2698 -- Process_Object_Declaration --
2699 --------------------------------
2701 procedure Process_Object_Declaration
2703 Has_No_Init
: Boolean := False;
2704 Is_Protected
: Boolean := False)
2706 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2707 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2709 Init_Typ
: Entity_Id
;
2710 -- The initialization type of the related object declaration. Note
2711 -- that this is not necessarily the same type as Obj_Typ because of
2712 -- possible type derivations.
2714 Obj_Typ
: Entity_Id
;
2715 -- The type of the related object declaration
2717 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2718 -- Func_Id denotes a build-in-place function. Generate the following
2721 -- if BIPallocfrom > Secondary_Stack'Pos
2722 -- and then BIPfinalizationmaster /= null
2725 -- type Ptr_Typ is access Obj_Typ;
2726 -- for Ptr_Typ'Storage_Pool
2727 -- use Base_Pool (BIPfinalizationmaster);
2729 -- Free (Ptr_Typ (Temp));
2733 -- Obj_Typ is the type of the current object, Temp is the original
2734 -- allocation which Obj_Id renames.
2736 procedure Find_Last_Init
2737 (Last_Init
: out Node_Id
;
2738 Body_Insert
: out Node_Id
);
2739 -- Find the last initialization call related to object declaration
2740 -- Decl. Last_Init denotes the last initialization call which follows
2741 -- Decl. Body_Insert denotes a node where the finalizer body could be
2742 -- potentially inserted after (if blocks are involved).
2744 -----------------------------
2745 -- Build_BIP_Cleanup_Stmts --
2746 -----------------------------
2748 function Build_BIP_Cleanup_Stmts
2749 (Func_Id
: Entity_Id
) return Node_Id
2751 Decls
: constant List_Id
:= New_List
;
2752 Fin_Mas_Id
: constant Entity_Id
:=
2753 Build_In_Place_Formal
2754 (Func_Id
, BIP_Finalization_Master
);
2755 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2756 Temp_Id
: constant Entity_Id
:=
2757 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2761 Free_Stmt
: Node_Id
;
2762 Pool_Id
: Entity_Id
;
2763 Ptr_Typ
: Entity_Id
;
2767 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2769 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2772 Make_Object_Renaming_Declaration
(Loc
,
2773 Defining_Identifier
=> Pool_Id
,
2775 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2777 Make_Explicit_Dereference
(Loc
,
2779 Make_Function_Call
(Loc
,
2781 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2782 Parameter_Associations
=> New_List
(
2783 Make_Explicit_Dereference
(Loc
,
2785 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2787 -- Create an access type which uses the storage pool of the
2788 -- caller's finalization master.
2791 -- type Ptr_Typ is access Func_Typ;
2793 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2796 Make_Full_Type_Declaration
(Loc
,
2797 Defining_Identifier
=> Ptr_Typ
,
2799 Make_Access_To_Object_Definition
(Loc
,
2800 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2802 -- Perform minor decoration in order to set the master and the
2803 -- storage pool attributes.
2805 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2806 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2807 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2809 if Debug_Generated_Code
then
2810 Set_Debug_Info_Needed
(Pool_Id
);
2813 -- Create an explicit free statement. Note that the free uses the
2814 -- caller's pool expressed as a renaming.
2817 Make_Free_Statement
(Loc
,
2819 Unchecked_Convert_To
(Ptr_Typ
,
2820 New_Occurrence_Of
(Temp_Id
, Loc
)));
2822 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2824 -- Create a block to house the dummy type and the instantiation as
2825 -- well as to perform the cleanup the temporary.
2831 -- Free (Ptr_Typ (Temp_Id));
2835 Make_Block_Statement
(Loc
,
2836 Declarations
=> Decls
,
2837 Handled_Statement_Sequence
=>
2838 Make_Handled_Sequence_Of_Statements
(Loc
,
2839 Statements
=> New_List
(Free_Stmt
)));
2842 -- if BIPfinalizationmaster /= null then
2846 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2847 Right_Opnd
=> Make_Null
(Loc
));
2849 -- For constrained or tagged results escalate the condition to
2850 -- include the allocation format. Generate:
2852 -- if BIPallocform > Secondary_Stack'Pos
2853 -- and then BIPfinalizationmaster /= null
2856 if not Is_Constrained
(Func_Typ
)
2857 or else Is_Tagged_Type
(Func_Typ
)
2860 Alloc
: constant Entity_Id
:=
2861 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2867 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2869 Make_Integer_Literal
(Loc
,
2871 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2873 Right_Opnd
=> Cond
);
2883 Make_If_Statement
(Loc
,
2885 Then_Statements
=> New_List
(Free_Blk
));
2886 end Build_BIP_Cleanup_Stmts
;
2888 --------------------
2889 -- Find_Last_Init --
2890 --------------------
2892 procedure Find_Last_Init
2893 (Last_Init
: out Node_Id
;
2894 Body_Insert
: out Node_Id
)
2896 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2897 -- Find the last initialization call within the statements of
2900 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2901 -- Determine whether node N denotes one of the initialization
2902 -- procedures of types Init_Typ or Obj_Typ.
2904 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2905 -- Obtain the next statement which follows list member Stmt while
2906 -- ignoring artifacts related to access-before-elaboration checks.
2908 -----------------------------
2909 -- Find_Last_Init_In_Block --
2910 -----------------------------
2912 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2913 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2917 -- Examine the individual statements of the block in reverse to
2918 -- locate the last initialization call.
2920 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2921 Stmt
:= Last
(Statements
(HSS
));
2922 while Present
(Stmt
) loop
2924 -- Peek inside nested blocks in case aborts are allowed
2926 if Nkind
(Stmt
) = N_Block_Statement
then
2927 return Find_Last_Init_In_Block
(Stmt
);
2929 elsif Is_Init_Call
(Stmt
) then
2938 end Find_Last_Init_In_Block
;
2944 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2945 function Is_Init_Proc_Of
2946 (Subp_Id
: Entity_Id
;
2947 Typ
: Entity_Id
) return Boolean;
2948 -- Determine whether subprogram Subp_Id is a valid init proc of
2951 ---------------------
2952 -- Is_Init_Proc_Of --
2953 ---------------------
2955 function Is_Init_Proc_Of
2956 (Subp_Id
: Entity_Id
;
2957 Typ
: Entity_Id
) return Boolean
2959 Deep_Init
: Entity_Id
:= Empty
;
2960 Prim_Init
: Entity_Id
:= Empty
;
2961 Type_Init
: Entity_Id
:= Empty
;
2964 -- Obtain all possible initialization routines of the
2965 -- related type and try to match the subprogram entity
2966 -- against one of them.
2970 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2972 -- Primitive Initialize
2974 if Is_Controlled
(Typ
) then
2975 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2977 if Present
(Prim_Init
) then
2978 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2982 -- Type initialization routine
2984 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2985 Type_Init
:= Base_Init_Proc
(Typ
);
2989 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2991 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2993 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2994 end Is_Init_Proc_Of
;
2998 Call_Id
: Entity_Id
;
3000 -- Start of processing for Is_Init_Call
3003 if Nkind
(N
) = N_Procedure_Call_Statement
3004 and then Nkind
(Name
(N
)) = N_Identifier
3006 Call_Id
:= Entity
(Name
(N
));
3008 -- Consider both the type of the object declaration and its
3009 -- related initialization type.
3012 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
3014 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
3020 -----------------------------
3021 -- Next_Suitable_Statement --
3022 -----------------------------
3024 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
3028 -- Skip call markers and Program_Error raises installed by the
3031 Result
:= Next
(Stmt
);
3032 while Present
(Result
) loop
3033 exit when Nkind
(Result
) not in
3034 N_Call_Marker | N_Raise_Program_Error
;
3040 end Next_Suitable_Statement
;
3048 Deep_Init_Found
: Boolean := False;
3049 -- A flag set when a call to [Deep_]Initialize has been found
3051 -- Start of processing for Find_Last_Init
3055 Body_Insert
:= Empty
;
3057 -- Object renamings and objects associated with controlled
3058 -- function results do not require initialization.
3064 Stmt
:= Next_Suitable_Statement
(Decl
);
3066 -- For an object with suppressed initialization, we check whether
3067 -- there is in fact no initialization expression. If there is not,
3068 -- then this is an object declaration that has been turned into a
3069 -- different object declaration that calls the build-in-place
3070 -- function in a 'Reference attribute, as in "F(...)'Reference".
3071 -- We search for that later object declaration, so that the
3072 -- Inc_Decl will be inserted after the call. Otherwise, if the
3073 -- call raises an exception, we will finalize the (uninitialized)
3074 -- object, which is wrong.
3076 if No_Initialization
(Decl
) then
3077 if No
(Expression
(Last_Init
)) then
3080 exit when No
(Last_Init
);
3081 exit when Nkind
(Last_Init
) = N_Object_Declaration
3082 and then Nkind
(Expression
(Last_Init
)) = N_Reference
3083 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
3085 and then Is_Expanded_Build_In_Place_Call
3086 (Prefix
(Expression
(Last_Init
)));
3092 -- In all other cases the initialization calls follow the related
3093 -- object. The general structure of object initialization built by
3094 -- routine Default_Initialize_Object is as follows:
3096 -- [begin -- aborts allowed
3098 -- Type_Init_Proc (Obj);
3099 -- [begin] -- exceptions allowed
3100 -- Deep_Initialize (Obj);
3101 -- [exception -- exceptions allowed
3103 -- Deep_Finalize (Obj, Self => False);
3106 -- [at end -- aborts allowed
3110 -- When aborts are allowed, the initialization calls are housed
3113 elsif Nkind
(Stmt
) = N_Block_Statement
then
3114 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
3115 Body_Insert
:= Stmt
;
3117 -- Otherwise the initialization calls follow the related object
3120 pragma Assert
(Present
(Stmt
));
3122 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
3124 -- Check for an optional call to Deep_Initialize which may
3125 -- appear within a block depending on whether the object has
3126 -- controlled components.
3128 if Present
(Stmt_2
) then
3129 if Nkind
(Stmt_2
) = N_Block_Statement
then
3130 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
3132 if Present
(Call
) then
3133 Deep_Init_Found
:= True;
3135 Body_Insert
:= Stmt_2
;
3138 elsif Is_Init_Call
(Stmt_2
) then
3139 Deep_Init_Found
:= True;
3140 Last_Init
:= Stmt_2
;
3141 Body_Insert
:= Last_Init
;
3145 -- If the object lacks a call to Deep_Initialize, then it must
3146 -- have a call to its related type init proc.
3148 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
3150 Body_Insert
:= Last_Init
;
3158 Count_Ins
: Node_Id
;
3160 Fin_Stmts
: List_Id
:= No_List
;
3163 Label_Id
: Entity_Id
;
3166 -- Start of processing for Process_Object_Declaration
3169 -- Handle the object type and the reference to the object
3171 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
3172 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
3175 if Is_Access_Type
(Obj_Typ
) then
3176 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
3177 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
3179 elsif Is_Concurrent_Type
(Obj_Typ
)
3180 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
3182 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
3183 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3185 elsif Is_Private_Type
(Obj_Typ
)
3186 and then Present
(Full_View
(Obj_Typ
))
3188 Obj_Typ
:= Full_View
(Obj_Typ
);
3189 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3191 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3192 Obj_Typ
:= Base_Type
(Obj_Typ
);
3193 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3200 Set_Etype
(Obj_Ref
, Obj_Typ
);
3202 -- Handle the initialization type of the object declaration
3204 Init_Typ
:= Obj_Typ
;
3206 if Is_Private_Type
(Init_Typ
)
3207 and then Present
(Full_View
(Init_Typ
))
3209 Init_Typ
:= Full_View
(Init_Typ
);
3211 elsif Is_Untagged_Derivation
(Init_Typ
) then
3212 Init_Typ
:= Root_Type
(Init_Typ
);
3219 -- Set a new value for the state counter and insert the statement
3220 -- after the object declaration. Generate:
3222 -- Counter := <value>;
3225 Make_Assignment_Statement
(Loc
,
3226 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3227 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3229 -- Insert the counter after all initialization has been done. The
3230 -- place of insertion depends on the context.
3232 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3234 -- The object is initialized by a build-in-place function call.
3235 -- The counter insertion point is after the function call.
3237 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3238 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3241 -- The object is initialized by an aggregate. Insert the counter
3242 -- after the last aggregate assignment.
3244 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3245 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3248 -- In all other cases the counter is inserted after the last call
3249 -- to either [Deep_]Initialize or the type-specific init proc.
3252 Find_Last_Init
(Count_Ins
, Body_Ins
);
3255 -- In all other cases the counter is inserted after the last call to
3256 -- either [Deep_]Initialize or the type-specific init proc.
3259 Find_Last_Init
(Count_Ins
, Body_Ins
);
3262 -- If the Initialize function is null or trivial, the call will have
3263 -- been replaced with a null statement, in which case place counter
3264 -- declaration after object declaration itself.
3266 if No
(Count_Ins
) then
3270 Insert_After
(Count_Ins
, Inc_Decl
);
3273 -- If the current declaration is the last in the list, the finalizer
3274 -- body needs to be inserted after the set counter statement for the
3275 -- current object declaration. This is complicated by the fact that
3276 -- the set counter statement may appear in abort deferred block. In
3277 -- that case, the proper insertion place is after the block.
3279 if No
(Finalizer_Insert_Nod
) then
3281 -- Insertion after an abort deferred block
3283 if Present
(Body_Ins
) then
3284 Finalizer_Insert_Nod
:= Body_Ins
;
3286 Finalizer_Insert_Nod
:= Inc_Decl
;
3290 -- Create the associated label with this object, generate:
3292 -- L<counter> : label;
3295 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3297 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3298 Label
:= Make_Label
(Loc
, Label_Id
);
3300 Prepend_To
(Finalizer_Decls
,
3301 Make_Implicit_Label_Declaration
(Loc
,
3302 Defining_Identifier
=> Entity
(Label_Id
),
3303 Label_Construct
=> Label
));
3305 -- Create the associated jump with this object, generate:
3307 -- when <counter> =>
3310 Prepend_To
(Jump_Alts
,
3311 Make_Case_Statement_Alternative
(Loc
,
3312 Discrete_Choices
=> New_List
(
3313 Make_Integer_Literal
(Loc
, Counter_Val
)),
3314 Statements
=> New_List
(
3315 Make_Goto_Statement
(Loc
,
3316 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3318 -- Insert the jump destination, generate:
3322 Append_To
(Finalizer_Stmts
, Label
);
3324 -- Disable warnings on Obj_Id. This works around an issue where GCC
3325 -- is not able to detect that Obj_Id is protected by a counter and
3326 -- emits spurious warnings.
3328 if not Comes_From_Source
(Obj_Id
) then
3329 Set_Warnings_Off
(Obj_Id
);
3332 -- Processing for simple protected objects. Such objects require
3333 -- manual finalization of their lock managers.
3335 if Is_Protected
then
3336 if Is_Simple_Protected_Type
(Obj_Typ
) then
3337 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3339 if Present
(Fin_Call
) then
3340 Fin_Stmts
:= New_List
(Fin_Call
);
3343 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3344 if Is_Record_Type
(Obj_Typ
) then
3345 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3346 elsif Is_Array_Type
(Obj_Typ
) then
3347 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3353 -- System.Tasking.Protected_Objects.Finalize_Protection
3361 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3362 Fin_Stmts
:= New_List
(
3363 Make_Block_Statement
(Loc
,
3364 Handled_Statement_Sequence
=>
3365 Make_Handled_Sequence_Of_Statements
(Loc
,
3366 Statements
=> Fin_Stmts
,
3368 Exception_Handlers
=> New_List
(
3369 Make_Exception_Handler
(Loc
,
3370 Exception_Choices
=> New_List
(
3371 Make_Others_Choice
(Loc
)),
3373 Statements
=> New_List
(
3374 Make_Null_Statement
(Loc
)))))));
3377 -- Processing for regular controlled objects
3382 -- [Deep_]Finalize (Obj);
3385 -- when Id : others =>
3386 -- if not Raised then
3388 -- Save_Occurrence (E, Id);
3397 -- Guard against a missing [Deep_]Finalize when the object type
3398 -- was not properly frozen.
3400 if No
(Fin_Call
) then
3401 Fin_Call
:= Make_Null_Statement
(Loc
);
3404 -- For CodePeer, the exception handlers normally generated here
3405 -- generate complex flowgraphs which result in capacity problems.
3406 -- Omitting these handlers for CodePeer is justified as follows:
3408 -- If a handler is dead, then omitting it is surely ok
3410 -- If a handler is live, then CodePeer should flag the
3411 -- potentially-exception-raising construct that causes it
3412 -- to be live. That is what we are interested in, not what
3413 -- happens after the exception is raised.
3415 if Exceptions_OK
and not CodePeer_Mode
then
3416 Fin_Stmts
:= New_List
(
3417 Make_Block_Statement
(Loc
,
3418 Handled_Statement_Sequence
=>
3419 Make_Handled_Sequence_Of_Statements
(Loc
,
3420 Statements
=> New_List
(Fin_Call
),
3422 Exception_Handlers
=> New_List
(
3423 Build_Exception_Handler
3424 (Finalizer_Data
, For_Package
)))));
3426 -- When exception handlers are prohibited, the finalization call
3427 -- appears unprotected. Any exception raised during finalization
3428 -- will bypass the circuitry which ensures the cleanup of all
3429 -- remaining objects.
3432 Fin_Stmts
:= New_List
(Fin_Call
);
3435 -- If we are dealing with a return object of a build-in-place
3436 -- function, generate the following cleanup statements:
3438 -- if BIPallocfrom > Secondary_Stack'Pos
3439 -- and then BIPfinalizationmaster /= null
3442 -- type Ptr_Typ is access Obj_Typ;
3443 -- for Ptr_Typ'Storage_Pool use
3444 -- Base_Pool (BIPfinalizationmaster.all).all;
3446 -- Free (Ptr_Typ (Temp));
3450 -- The generated code effectively detaches the temporary from the
3451 -- caller finalization master and deallocates the object.
3453 if Is_Return_Object
(Obj_Id
) then
3455 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3457 if Is_Build_In_Place_Function
(Func_Id
)
3458 and then Needs_BIP_Finalization_Master
(Func_Id
)
3460 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3465 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3466 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3468 -- Temporaries created for the purpose of "exporting" a
3469 -- transient object out of an Expression_With_Actions (EWA)
3470 -- need guards. The following illustrates the usage of such
3473 -- Access_Typ : access [all] Obj_Typ;
3474 -- Temp : Access_Typ := null;
3475 -- <Counter> := ...;
3478 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3479 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3481 -- Temp := Ctrl_Trans'Unchecked_Access;
3484 -- The finalization machinery does not process EWA nodes as
3485 -- this may lead to premature finalization of expressions. Note
3486 -- that Temp is marked as being properly initialized regardless
3487 -- of whether the initialization of Ctrl_Trans succeeded. Since
3488 -- a failed initialization may leave Temp with a value of null,
3489 -- add a guard to handle this case:
3491 -- if Obj /= null then
3492 -- <object finalization statements>
3495 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3496 N_Object_Declaration
3498 Fin_Stmts
:= New_List
(
3499 Make_If_Statement
(Loc
,
3502 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3503 Right_Opnd
=> Make_Null
(Loc
)),
3504 Then_Statements
=> Fin_Stmts
));
3506 -- Return objects use a flag to aid in processing their
3507 -- potential finalization when the enclosing function fails
3508 -- to return properly. Generate:
3511 -- <object finalization statements>
3515 Fin_Stmts
:= New_List
(
3516 Make_If_Statement
(Loc
,
3521 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3523 Then_Statements
=> Fin_Stmts
));
3528 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3530 -- Since the declarations are examined in reverse, the state counter
3531 -- must be decremented in order to keep with the true position of
3534 Counter_Val
:= Counter_Val
- 1;
3535 end Process_Object_Declaration
;
3537 -------------------------------------
3538 -- Process_Tagged_Type_Declaration --
3539 -------------------------------------
3541 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3542 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3543 DT_Ptr
: constant Entity_Id
:=
3544 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3547 -- Ada.Tags.Unregister_Tag (<Typ>P);
3549 Append_To
(Tagged_Type_Stmts
,
3550 Make_Procedure_Call_Statement
(Loc
,
3552 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3553 Parameter_Associations
=> New_List
(
3554 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3555 end Process_Tagged_Type_Declaration
;
3557 -- Start of processing for Build_Finalizer_Helper
3562 -- Do not perform this expansion in SPARK mode because it is not
3565 if GNATprove_Mode
then
3569 -- Step 1: Extract all lists which may contain controlled objects or
3570 -- library-level tagged types.
3572 if For_Package_Spec
then
3573 Decls
:= Visible_Declarations
(Specification
(N
));
3574 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3576 -- Retrieve the package spec id
3578 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3580 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3581 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3584 -- Accept statement, block, entry body, package body, protected body,
3585 -- subprogram body or task body.
3588 Decls
:= Declarations
(N
);
3589 HSS
:= Handled_Statement_Sequence
(N
);
3591 if Present
(HSS
) then
3592 if Present
(Statements
(HSS
)) then
3593 Stmts
:= Statements
(HSS
);
3596 if Present
(At_End_Proc
(HSS
)) then
3597 Prev_At_End
:= At_End_Proc
(HSS
);
3601 -- Retrieve the package spec id for package bodies
3603 if For_Package_Body
then
3604 Spec_Id
:= Corresponding_Spec
(N
);
3608 -- Do not process nested packages since those are handled by the
3609 -- enclosing scope's finalizer. Do not process non-expanded package
3610 -- instantiations since those will be re-analyzed and re-expanded.
3614 (not Is_Library_Level_Entity
(Spec_Id
)
3616 -- Nested packages are library level entities, but do not need to
3617 -- be processed separately.
3619 or else Scope_Depth
(Spec_Id
) /= Uint_1
3620 or else (Is_Generic_Instance
(Spec_Id
)
3621 and then Package_Instantiation
(Spec_Id
) /= N
))
3623 -- Still need to process package body instantiations which may
3624 -- contain objects requiring finalization.
3628 and then Is_Library_Level_Entity
(Spec_Id
)
3629 and then Is_Generic_Instance
(Spec_Id
))
3634 -- Step 2: Object [pre]processing
3638 -- Preprocess the visible declarations now in order to obtain the
3639 -- correct number of controlled object by the time the private
3640 -- declarations are processed.
3642 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3644 -- From all the possible contexts, only package specifications may
3645 -- have private declarations.
3647 if For_Package_Spec
then
3648 Process_Declarations
3649 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3652 -- The current context may lack controlled objects, but require some
3653 -- other form of completion (task termination for instance). In such
3654 -- cases, the finalizer must be created and carry the additional
3657 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3661 -- The preprocessing has determined that the context has controlled
3662 -- objects or library-level tagged types.
3664 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3666 -- Private declarations are processed first in order to preserve
3667 -- possible dependencies between public and private objects.
3669 if For_Package_Spec
then
3670 Process_Declarations
(Priv_Decls
);
3673 Process_Declarations
(Decls
);
3679 -- Preprocess both declarations and statements
3681 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3682 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3684 -- At this point it is known that N has controlled objects. Ensure
3685 -- that N has a declarative list since the finalizer spec will be
3688 if Has_Ctrl_Objs
and then No
(Decls
) then
3689 Set_Declarations
(N
, New_List
);
3690 Decls
:= Declarations
(N
);
3691 Spec_Decls
:= Decls
;
3694 -- The current context may lack controlled objects, but require some
3695 -- other form of completion (task termination for instance). In such
3696 -- cases, the finalizer must be created and carry the additional
3699 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3703 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3704 Process_Declarations
(Stmts
);
3705 Process_Declarations
(Decls
);
3709 -- Step 3: Finalizer creation
3711 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3714 end Build_Finalizer_Helper
;
3716 --------------------------
3717 -- Build_Finalizer_Call --
3718 --------------------------
3720 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3721 Is_Prot_Body
: constant Boolean :=
3722 Nkind
(N
) = N_Subprogram_Body
3723 and then Is_Protected_Subprogram_Body
(N
);
3724 -- Determine whether N denotes the protected version of a subprogram
3725 -- which belongs to a protected type.
3727 Loc
: constant Source_Ptr
:= Sloc
(N
);
3731 -- Do not perform this expansion in SPARK mode because we do not create
3732 -- finalizers in the first place.
3734 if GNATprove_Mode
then
3738 -- The At_End handler should have been assimilated by the finalizer
3740 HSS
:= Handled_Statement_Sequence
(N
);
3741 pragma Assert
(No
(At_End_Proc
(HSS
)));
3743 -- If the construct to be cleaned up is a protected subprogram body, the
3744 -- finalizer call needs to be associated with the block which wraps the
3745 -- unprotected version of the subprogram. The following illustrates this
3748 -- procedure Prot_SubpP is
3749 -- procedure finalizer is
3751 -- Service_Entries (Prot_Obj);
3758 -- Prot_SubpN (Prot_Obj);
3764 if Is_Prot_Body
then
3765 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3767 -- An At_End handler and regular exception handlers cannot coexist in
3768 -- the same statement sequence. Wrap the original statements in a block.
3770 elsif Present
(Exception_Handlers
(HSS
)) then
3772 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3777 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3779 Set_Handled_Statement_Sequence
(N
,
3780 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3782 HSS
:= Handled_Statement_Sequence
(N
);
3783 Set_End_Label
(HSS
, End_Lab
);
3787 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3789 -- Attach reference to finalizer to tree, for LLVM use
3791 Set_Parent
(At_End_Proc
(HSS
), HSS
);
3793 Analyze
(At_End_Proc
(HSS
));
3794 Expand_At_End_Handler
(HSS
, Empty
);
3795 end Build_Finalizer_Call
;
3797 ---------------------
3798 -- Build_Finalizer --
3799 ---------------------
3801 procedure Build_Finalizer
3803 Clean_Stmts
: List_Id
;
3804 Mark_Id
: Entity_Id
;
3805 Top_Decls
: List_Id
;
3806 Defer_Abort
: Boolean;
3807 Fin_Id
: out Entity_Id
)
3809 Def_Ent
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
3810 Loc
: constant Source_Ptr
:= Sloc
(N
);
3812 -- Declarations used for the creation of _finalization_controller
3814 Fin_Old_Id
: Entity_Id
:= Empty
;
3815 Fin_Controller_Id
: Entity_Id
:= Empty
;
3816 Fin_Controller_Decls
: List_Id
;
3817 Fin_Controller_Stmts
: List_Id
;
3818 Fin_Controller_Body
: Node_Id
:= Empty
;
3819 Fin_Controller_Spec
: Node_Id
:= Empty
;
3820 Postconditions_Call
: Node_Id
:= Empty
;
3822 -- Defining identifiers for local objects used to store exception info
3824 Raised_Post_Exception_Id
: Entity_Id
:= Empty
;
3825 Raised_Finalization_Exception_Id
: Entity_Id
:= Empty
;
3826 Saved_Exception_Id
: Entity_Id
:= Empty
;
3828 -- Start of processing for Build_Finalizer
3831 -- Create the general finalization routine
3833 Build_Finalizer_Helper
3835 Clean_Stmts
=> Clean_Stmts
,
3837 Top_Decls
=> Top_Decls
,
3838 Defer_Abort
=> Defer_Abort
,
3840 Finalize_Old_Only
=> False);
3842 -- When postconditions are present, expansion gets much more complicated
3843 -- due to both the fact that they must be called after finalization and
3844 -- that finalization of 'Old objects must occur after the postconditions
3847 -- Additionally, exceptions between general finalization and 'Old
3848 -- finalization must be propagated correctly and exceptions which happen
3849 -- during _postconditions need to be saved and reraised after
3850 -- finalization of 'Old objects.
3854 -- Postcond_Enabled := False;
3856 -- procedure _finalization_controller is
3858 -- -- Exception capturing and tracking
3860 -- Saved_Exception : Exception_Occurrence;
3861 -- Raised_Post_Exception : Boolean := False;
3862 -- Raised_Finalization_Exception : Boolean := False;
3864 -- -- Start of processing for _finalization_controller
3867 -- -- Perform general finalization
3873 -- -- Save the exception
3875 -- Raised_Finalization_Exception := True;
3877 -- (Saved_Exception, Get_Current_Excep.all);
3880 -- -- Perform postcondition checks after general finalization, but
3881 -- -- before finalization of 'Old related objects.
3883 -- if not Raised_Finalization_Exception
3884 -- and then Return_Success_For_Postcond
3887 -- -- Re-enable postconditions and check them
3889 -- Postcond_Enabled := True;
3890 -- _postconditions [(Result_Obj_For_Postcond[.all])];
3893 -- -- Save the exception
3895 -- Raised_Post_Exception := True;
3897 -- (Saved_Exception, Get_Current_Excep.all);
3901 -- -- Finally finalize 'Old related objects
3907 -- -- Reraise the previous finalization error if there is
3910 -- if Raised_Finalization_Exception then
3911 -- Reraise_Occurrence (Saved_Exception);
3914 -- -- Otherwise, reraise the current one
3919 -- -- Reraise any saved exception
3921 -- if Raised_Finalization_Exception
3922 -- or else Raised_Post_Exception
3924 -- Reraise_Occurrence (Saved_Exception);
3926 -- end _finalization_controller;
3928 if Nkind
(N
) = N_Subprogram_Body
3929 and then Present
(Postconditions_Proc
(Def_Ent
))
3931 Fin_Controller_Stmts
:= New_List
;
3932 Fin_Controller_Decls
:= New_List
;
3934 -- Build the 'Old finalizer
3936 Build_Finalizer_Helper
3938 Clean_Stmts
=> Empty_List
,
3940 Top_Decls
=> Top_Decls
,
3941 Defer_Abort
=> Defer_Abort
,
3942 Fin_Id
=> Fin_Old_Id
,
3943 Finalize_Old_Only
=> True);
3945 -- Create local declarations for _finalization_controller needed for
3946 -- saving exceptions.
3950 -- Saved_Exception : Exception_Occurrence;
3951 -- Raised_Post_Exception : Boolean := False;
3952 -- Raised_Finalization_Exception : Boolean := False;
3954 Saved_Exception_Id
:= Make_Temporary
(Loc
, 'S');
3955 Raised_Post_Exception_Id
:= Make_Temporary
(Loc
, 'P');
3956 Raised_Finalization_Exception_Id
:= Make_Temporary
(Loc
, 'F');
3958 Append_List_To
(Fin_Controller_Decls
, New_List
(
3959 Make_Object_Declaration
(Loc
,
3960 Defining_Identifier
=> Saved_Exception_Id
,
3961 Object_Definition
=>
3962 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)),
3963 Make_Object_Declaration
(Loc
,
3964 Defining_Identifier
=> Raised_Post_Exception_Id
,
3965 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3966 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)),
3967 Make_Object_Declaration
(Loc
,
3968 Defining_Identifier
=> Raised_Finalization_Exception_Id
,
3969 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3970 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
3972 -- Call _finalizer and save any exceptions which occur
3980 -- Raised_Finalization_Exception := True;
3982 -- (Saved_Exception, Get_Current_Excep.all);
3985 if Present
(Fin_Id
) then
3986 Append_To
(Fin_Controller_Stmts
,
3987 Make_Block_Statement
(Loc
,
3988 Handled_Statement_Sequence
=>
3989 Make_Handled_Sequence_Of_Statements
(Loc
,
3990 Statements
=> New_List
(
3991 Make_Procedure_Call_Statement
(Loc
,
3992 Name
=> New_Occurrence_Of
(Fin_Id
, Loc
))),
3993 Exception_Handlers
=> New_List
(
3994 Make_Exception_Handler
(Loc
,
3995 Exception_Choices
=> New_List
(
3996 Make_Others_Choice
(Loc
)),
3997 Statements
=> New_List
(
3998 Make_Assignment_Statement
(Loc
,
4001 (Raised_Finalization_Exception_Id
, Loc
),
4003 New_Occurrence_Of
(Standard_True
, Loc
)),
4004 Make_Procedure_Call_Statement
(Loc
,
4007 (RTE
(RE_Save_Occurrence
), Loc
),
4008 Parameter_Associations
=> New_List
(
4010 (Saved_Exception_Id
, Loc
),
4011 Make_Explicit_Dereference
(Loc
,
4013 Make_Function_Call
(Loc
,
4015 Make_Explicit_Dereference
(Loc
,
4018 (RTE
(RE_Get_Current_Excep
),
4022 -- Create the call to postconditions based on the kind of the current
4023 -- subprogram, and the type of the Result_Obj_For_Postcond.
4027 -- _postconditions (Result_Obj_For_Postcond[.all]);
4033 if Ekind
(Def_Ent
) = E_Procedure
then
4034 Postconditions_Call
:=
4035 Make_Procedure_Call_Statement
(Loc
,
4038 (Postconditions_Proc
(Def_Ent
), Loc
));
4040 Postconditions_Call
:=
4041 Make_Procedure_Call_Statement
(Loc
,
4044 (Postconditions_Proc
(Def_Ent
), Loc
),
4045 Parameter_Associations
=> New_List
(
4046 (if Is_Elementary_Type
(Etype
(Def_Ent
)) then
4048 (Get_Result_Object_For_Postcond
4051 Make_Explicit_Dereference
(Loc
,
4053 (Get_Result_Object_For_Postcond
4054 (Def_Ent
), Loc
)))));
4057 -- Call _postconditions when no general finalization exceptions have
4058 -- occured taking care to enable the postconditions and save any
4059 -- exception occurrences.
4063 -- if not Raised_Finalization_Exception
4064 -- and then Return_Success_For_Postcond
4067 -- Postcond_Enabled := True;
4068 -- _postconditions [(Result_Obj_For_Postcond[.all])];
4071 -- Raised_Post_Exception := True;
4073 -- (Saved_Exception, Get_Current_Excep.all);
4077 Append_To
(Fin_Controller_Stmts
,
4078 Make_If_Statement
(Loc
,
4085 (Raised_Finalization_Exception_Id
, Loc
)),
4088 (Get_Return_Success_For_Postcond
(Def_Ent
), Loc
)),
4089 Then_Statements
=> New_List
(
4090 Make_Block_Statement
(Loc
,
4091 Handled_Statement_Sequence
=>
4092 Make_Handled_Sequence_Of_Statements
(Loc
,
4093 Statements
=> New_List
(
4094 Make_Assignment_Statement
(Loc
,
4097 (Get_Postcond_Enabled
(Def_Ent
), Loc
),
4100 (Standard_True
, Loc
)),
4101 Postconditions_Call
),
4102 Exception_Handlers
=> New_List
(
4103 Make_Exception_Handler
(Loc
,
4104 Exception_Choices
=> New_List
(
4105 Make_Others_Choice
(Loc
)),
4106 Statements
=> New_List
(
4107 Make_Assignment_Statement
(Loc
,
4110 (Raised_Post_Exception_Id
, Loc
),
4112 New_Occurrence_Of
(Standard_True
, Loc
)),
4113 Make_Procedure_Call_Statement
(Loc
,
4116 (RTE
(RE_Save_Occurrence
), Loc
),
4117 Parameter_Associations
=> New_List
(
4119 (Saved_Exception_Id
, Loc
),
4120 Make_Explicit_Dereference
(Loc
,
4122 Make_Function_Call
(Loc
,
4124 Make_Explicit_Dereference
(Loc
,
4127 (RTE
(RE_Get_Current_Excep
),
4130 -- Call _finalizer_old and reraise any exception that occurred during
4131 -- initial finalization within the exception handler. Otherwise,
4132 -- propagate the current exception.
4140 -- if Raised_Finalization_Exception then
4141 -- Reraise_Occurrence (Saved_Exception);
4146 if Present
(Fin_Old_Id
) then
4147 Append_To
(Fin_Controller_Stmts
,
4148 Make_Block_Statement
(Loc
,
4149 Handled_Statement_Sequence
=>
4150 Make_Handled_Sequence_Of_Statements
(Loc
,
4151 Statements
=> New_List
(
4152 Make_Procedure_Call_Statement
(Loc
,
4153 Name
=> New_Occurrence_Of
(Fin_Old_Id
, Loc
))),
4154 Exception_Handlers
=> New_List
(
4155 Make_Exception_Handler
(Loc
,
4156 Exception_Choices
=> New_List
(
4157 Make_Others_Choice
(Loc
)),
4158 Statements
=> New_List
(
4159 Make_If_Statement
(Loc
,
4162 (Raised_Finalization_Exception_Id
, Loc
),
4163 Then_Statements
=> New_List
(
4164 Make_Procedure_Call_Statement
(Loc
,
4167 (RTE
(RE_Reraise_Occurrence
), Loc
),
4168 Parameter_Associations
=> New_List
(
4170 (Saved_Exception_Id
, Loc
))))),
4171 Make_Raise_Statement
(Loc
)))))));
4174 -- Once finalization is complete reraise any pending exceptions
4178 -- if Raised_Post_Exception
4179 -- or else Raised_Finalization_Exception
4181 -- Reraise_Occurrence (Saved_Exception);
4184 Append_To
(Fin_Controller_Stmts
,
4185 Make_If_Statement
(Loc
,
4190 (Raised_Post_Exception_Id
, Loc
),
4193 (Raised_Finalization_Exception_Id
, Loc
)),
4194 Then_Statements
=> New_List
(
4195 Make_Procedure_Call_Statement
(Loc
,
4197 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4198 Parameter_Associations
=> New_List
(
4200 (Saved_Exception_Id
, Loc
))))));
4202 -- Make the finalization controller subprogram body and declaration.
4205 -- procedure _finalization_controller;
4207 -- procedure _finalization_controller is
4209 -- [Fin_Controller_Stmts];
4212 Fin_Controller_Id
:=
4213 Make_Defining_Identifier
(Loc
,
4214 Chars
=> New_External_Name
(Name_uFinalization_Controller
));
4216 Fin_Controller_Spec
:=
4217 Make_Subprogram_Declaration
(Loc
,
4219 Make_Procedure_Specification
(Loc
,
4220 Defining_Unit_Name
=> Fin_Controller_Id
));
4222 Fin_Controller_Body
:=
4223 Make_Subprogram_Body
(Loc
,
4225 Make_Procedure_Specification
(Loc
,
4226 Defining_Unit_Name
=>
4227 Make_Defining_Identifier
(Loc
, Chars
(Fin_Controller_Id
))),
4228 Declarations
=> Fin_Controller_Decls
,
4229 Handled_Statement_Sequence
=>
4230 Make_Handled_Sequence_Of_Statements
(Loc
,
4231 Statements
=> Fin_Controller_Stmts
));
4233 -- Disable _postconditions calls which get generated before return
4234 -- statements to delay their evaluation until after finalization.
4236 -- This is done by way of the local Postcond_Enabled object which is
4237 -- initially assigned to True - we then create an assignment within
4238 -- the subprogram's declaration to make it False and assign it back
4239 -- to True before _postconditions is called within
4240 -- _finalization_controller.
4244 -- Postcond_Enable := False;
4246 Append_To
(Top_Decls
,
4247 Make_Assignment_Statement
(Loc
,
4250 (Get_Postcond_Enabled
(Def_Ent
), Loc
),
4253 (Standard_False
, Loc
)));
4255 -- Add the subprogram to the list of declarations an analyze it
4257 Append_To
(Top_Decls
, Fin_Controller_Spec
);
4258 Analyze
(Fin_Controller_Spec
);
4259 Insert_After
(Fin_Controller_Spec
, Fin_Controller_Body
);
4260 Analyze
(Fin_Controller_Body
, Suppress
=> All_Checks
);
4262 -- Return the finalization controller as the result Fin_Id
4264 Fin_Id
:= Fin_Controller_Id
;
4266 end Build_Finalizer
;
4268 ---------------------
4269 -- Build_Late_Proc --
4270 ---------------------
4272 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
4274 for Final_Prim
in Name_Of
'Range loop
4275 if Name_Of
(Final_Prim
) = Nam
then
4278 (Prim
=> Final_Prim
,
4280 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
4283 end Build_Late_Proc
;
4285 -------------------------------
4286 -- Build_Object_Declarations --
4287 -------------------------------
4289 procedure Build_Object_Declarations
4290 (Data
: out Finalization_Exception_Data
;
4293 For_Package
: Boolean := False)
4298 -- This variable captures an unused dummy internal entity, see the
4299 -- comment associated with its use.
4302 pragma Assert
(Decls
/= No_List
);
4304 -- Always set the proper location as it may be needed even when
4305 -- exception propagation is forbidden.
4309 if Restriction_Active
(No_Exception_Propagation
) then
4310 Data
.Abort_Id
:= Empty
;
4312 Data
.Raised_Id
:= Empty
;
4316 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
4318 -- In certain scenarios, finalization can be triggered by an abort. If
4319 -- the finalization itself fails and raises an exception, the resulting
4320 -- Program_Error must be supressed and replaced by an abort signal. In
4321 -- order to detect this scenario, save the state of entry into the
4322 -- finalization code.
4324 -- This is not needed for library-level finalizers as they are called by
4325 -- the environment task and cannot be aborted.
4327 if not For_Package
then
4328 if Abort_Allowed
then
4329 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
4332 -- Abort_Id : constant Boolean := <A_Expr>;
4335 Make_Object_Declaration
(Loc
,
4336 Defining_Identifier
=> Data
.Abort_Id
,
4337 Constant_Present
=> True,
4338 Object_Definition
=>
4339 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4341 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
4343 -- Abort is not required
4346 -- Generate a dummy entity to ensure that the internal symbols are
4347 -- in sync when a unit is compiled with and without aborts.
4349 Dummy
:= Make_Temporary
(Loc
, 'A');
4350 Data
.Abort_Id
:= Empty
;
4353 -- Library-level finalizers
4356 Data
.Abort_Id
:= Empty
;
4359 if Exception_Extra_Info
then
4360 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
4363 -- E_Id : Exception_Occurrence;
4366 Make_Object_Declaration
(Loc
,
4367 Defining_Identifier
=> Data
.E_Id
,
4368 Object_Definition
=>
4369 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
4370 Set_No_Initialization
(Decl
);
4372 Append_To
(Decls
, Decl
);
4379 -- Raised_Id : Boolean := False;
4382 Make_Object_Declaration
(Loc
,
4383 Defining_Identifier
=> Data
.Raised_Id
,
4384 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4385 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
4387 if Debug_Generated_Code
then
4388 Set_Debug_Info_Needed
(Data
.Raised_Id
);
4390 end Build_Object_Declarations
;
4392 ---------------------------
4393 -- Build_Raise_Statement --
4394 ---------------------------
4396 function Build_Raise_Statement
4397 (Data
: Finalization_Exception_Data
) return Node_Id
4403 -- Standard run-time use the specialized routine
4404 -- Raise_From_Controlled_Operation.
4406 if Exception_Extra_Info
4407 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
4410 Make_Procedure_Call_Statement
(Data
.Loc
,
4413 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
4414 Parameter_Associations
=>
4415 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
4417 -- Restricted run-time: exception messages are not supported and hence
4418 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
4423 Make_Raise_Program_Error
(Data
.Loc
,
4424 Reason
=> PE_Finalize_Raised_Exception
);
4429 -- Raised_Id and then not Abort_Id
4433 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
4435 if Present
(Data
.Abort_Id
) then
4436 Expr
:= Make_And_Then
(Data
.Loc
,
4439 Make_Op_Not
(Data
.Loc
,
4440 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
4445 -- if Raised_Id and then not Abort_Id then
4446 -- Raise_From_Controlled_Operation (E_Id);
4448 -- raise Program_Error; -- restricted runtime
4452 Make_If_Statement
(Data
.Loc
,
4454 Then_Statements
=> New_List
(Stmt
));
4455 end Build_Raise_Statement
;
4457 -----------------------------
4458 -- Build_Record_Deep_Procs --
4459 -----------------------------
4461 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
4465 (Prim
=> Initialize_Case
,
4467 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
4469 if not Is_Limited_View
(Typ
) then
4472 (Prim
=> Adjust_Case
,
4474 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
4477 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
4478 -- suppressed since these routine will not be used.
4480 if not Restriction_Active
(No_Finalization
) then
4483 (Prim
=> Finalize_Case
,
4485 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
4487 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
4489 if not CodePeer_Mode
then
4492 (Prim
=> Address_Case
,
4494 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
4497 end Build_Record_Deep_Procs
;
4503 function Cleanup_Array
4506 Typ
: Entity_Id
) return List_Id
4508 Loc
: constant Source_Ptr
:= Sloc
(N
);
4509 Index_List
: constant List_Id
:= New_List
;
4511 function Free_Component
return List_Id
;
4512 -- Generate the code to finalize the task or protected subcomponents
4513 -- of a single component of the array.
4515 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
4516 -- Generate a loop over one dimension of the array
4518 --------------------
4519 -- Free_Component --
4520 --------------------
4522 function Free_Component
return List_Id
is
4523 Stmts
: List_Id
:= New_List
;
4525 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
4528 -- Component type is known to contain tasks or protected objects
4531 Make_Indexed_Component
(Loc
,
4532 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
4533 Expressions
=> Index_List
);
4535 Set_Etype
(Tsk
, C_Typ
);
4537 if Is_Task_Type
(C_Typ
) then
4538 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4540 elsif Is_Simple_Protected_Type
(C_Typ
) then
4541 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4543 elsif Is_Record_Type
(C_Typ
) then
4544 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
4546 elsif Is_Array_Type
(C_Typ
) then
4547 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
4553 ------------------------
4554 -- Free_One_Dimension --
4555 ------------------------
4557 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
4561 if Dim
> Number_Dimensions
(Typ
) then
4562 return Free_Component
;
4564 -- Here we generate the required loop
4567 Index
:= Make_Temporary
(Loc
, 'J');
4568 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
4571 Make_Implicit_Loop_Statement
(N
,
4572 Identifier
=> Empty
,
4574 Make_Iteration_Scheme
(Loc
,
4575 Loop_Parameter_Specification
=>
4576 Make_Loop_Parameter_Specification
(Loc
,
4577 Defining_Identifier
=> Index
,
4578 Discrete_Subtype_Definition
=>
4579 Make_Attribute_Reference
(Loc
,
4580 Prefix
=> Duplicate_Subexpr
(Obj
),
4581 Attribute_Name
=> Name_Range
,
4582 Expressions
=> New_List
(
4583 Make_Integer_Literal
(Loc
, Dim
))))),
4584 Statements
=> Free_One_Dimension
(Dim
+ 1)));
4586 end Free_One_Dimension
;
4588 -- Start of processing for Cleanup_Array
4591 return Free_One_Dimension
(1);
4594 --------------------
4595 -- Cleanup_Record --
4596 --------------------
4598 function Cleanup_Record
4601 Typ
: Entity_Id
) return List_Id
4603 Loc
: constant Source_Ptr
:= Sloc
(N
);
4604 Stmts
: constant List_Id
:= New_List
;
4605 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
4611 if Has_Discriminants
(U_Typ
)
4612 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
4613 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
4616 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
4618 -- For now, do not attempt to free a component that may appear in a
4619 -- variant, and instead issue a warning. Doing this "properly" would
4620 -- require building a case statement and would be quite a mess. Note
4621 -- that the RM only requires that free "work" for the case of a task
4622 -- access value, so already we go way beyond this in that we deal
4623 -- with the array case and non-discriminated record cases.
4626 ("task/protected object in variant record will not be freed??", N
);
4627 return New_List
(Make_Null_Statement
(Loc
));
4630 Comp
:= First_Component
(U_Typ
);
4631 while Present
(Comp
) loop
4632 if Has_Task
(Etype
(Comp
))
4633 or else Has_Simple_Protected_Object
(Etype
(Comp
))
4636 Make_Selected_Component
(Loc
,
4637 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
4638 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
4639 Set_Etype
(Tsk
, Etype
(Comp
));
4641 if Is_Task_Type
(Etype
(Comp
)) then
4642 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4644 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
4645 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4647 elsif Is_Record_Type
(Etype
(Comp
)) then
4649 -- Recurse, by generating the prefix of the argument to the
4650 -- eventual cleanup call.
4652 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
4654 elsif Is_Array_Type
(Etype
(Comp
)) then
4655 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
4659 Next_Component
(Comp
);
4665 ------------------------------
4666 -- Cleanup_Protected_Object --
4667 ------------------------------
4669 function Cleanup_Protected_Object
4671 Ref
: Node_Id
) return Node_Id
4673 Loc
: constant Source_Ptr
:= Sloc
(N
);
4676 -- For restricted run-time libraries (Ravenscar), tasks are
4677 -- non-terminating, and protected objects can only appear at library
4678 -- level, so we do not want finalization of protected objects.
4680 if Restricted_Profile
then
4685 Make_Procedure_Call_Statement
(Loc
,
4687 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4688 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4690 end Cleanup_Protected_Object
;
4696 function Cleanup_Task
4698 Ref
: Node_Id
) return Node_Id
4700 Loc
: constant Source_Ptr
:= Sloc
(N
);
4703 -- For restricted run-time libraries (Ravenscar), tasks are
4704 -- non-terminating and they can only appear at library level,
4705 -- so we do not want finalization of task objects.
4707 if Restricted_Profile
then
4712 Make_Procedure_Call_Statement
(Loc
,
4714 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4715 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4719 --------------------------------------
4720 -- Check_Unnesting_Elaboration_Code --
4721 --------------------------------------
4723 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4724 Loc
: constant Source_Ptr
:= Sloc
(N
);
4725 Block_Elab_Proc
: Entity_Id
:= Empty
;
4727 procedure Set_Block_Elab_Proc
;
4728 -- Create a defining identifier for a procedure that will replace
4729 -- a block with nested subprograms (unless it has already been created,
4730 -- in which case this is a no-op).
4732 procedure Set_Block_Elab_Proc
is
4734 if No
(Block_Elab_Proc
) then
4736 Make_Defining_Identifier
(Loc
, Chars
=> New_Internal_Name
('I'));
4738 end Set_Block_Elab_Proc
;
4740 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4741 -- Find entities in the elaboration code of a library package body that
4742 -- contain or represent a subprogram body. A body can appear within a
4743 -- block or a loop or can appear by itself if generated for an object
4744 -- declaration that involves controlled actions. The first such entity
4745 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4746 -- that will be used to reset the scopes of all entities that become
4747 -- local to the new elaboration procedure. This is needed for subsequent
4748 -- unnesting actions, which depend on proper setting of the Scope links
4749 -- to determine the nesting level of each subprogram.
4751 -----------------------
4752 -- Find_Local_Scope --
4753 -----------------------
4755 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4762 while Present
(Stat
) loop
4763 case Nkind
(Stat
) is
4764 when N_Block_Statement
=>
4765 if Present
(Identifier
(Stat
)) then
4766 Id
:= Entity
(Identifier
(Stat
));
4768 -- The Scope of this block needs to be reset to the new
4769 -- procedure if the block contains nested subprograms.
4771 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4772 Set_Block_Elab_Proc
;
4773 Set_Scope
(Id
, Block_Elab_Proc
);
4777 when N_Loop_Statement
=>
4778 Id
:= Entity
(Identifier
(Stat
));
4780 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4781 if Scope
(Id
) = Current_Scope
then
4782 Set_Block_Elab_Proc
;
4783 Set_Scope
(Id
, Block_Elab_Proc
);
4787 -- We traverse the loop's statements as well, which may
4788 -- include other block (etc.) statements that need to have
4789 -- their Scope set to Block_Elab_Proc. (Is this really the
4790 -- case, or do such nested blocks refer to the loop scope
4791 -- rather than the loop's enclosing scope???.)
4793 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4795 when N_If_Statement
=>
4796 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4797 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4799 Node
:= First
(Elsif_Parts
(Stat
));
4800 while Present
(Node
) loop
4801 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4805 when N_Case_Statement
=>
4806 Node
:= First
(Alternatives
(Stat
));
4807 while Present
(Node
) loop
4808 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4812 -- Reset the Scope of a subprogram occurring at the top level
4814 when N_Subprogram_Body
=>
4815 Id
:= Defining_Entity
(Stat
);
4817 Set_Block_Elab_Proc
;
4818 Set_Scope
(Id
, Block_Elab_Proc
);
4826 end Reset_Scopes_To_Block_Elab_Proc
;
4830 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4831 Elab_Body
: Node_Id
;
4832 Elab_Call
: Node_Id
;
4834 -- Start of processing for Check_Unnesting_Elaboration_Code
4837 if Present
(H_Seq
) then
4838 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4840 -- There may be subprograms declared in the exception handlers
4841 -- of the current body.
4843 if Present
(Exception_Handlers
(H_Seq
)) then
4845 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4847 while Present
(Handler
) loop
4848 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4855 if Present
(Block_Elab_Proc
) then
4857 Make_Subprogram_Body
(Loc
,
4859 Make_Procedure_Specification
(Loc
,
4860 Defining_Unit_Name
=> Block_Elab_Proc
),
4861 Declarations
=> New_List
,
4862 Handled_Statement_Sequence
=>
4863 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4866 Make_Procedure_Call_Statement
(Loc
,
4867 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4869 Append_To
(Declarations
(N
), Elab_Body
);
4870 Analyze
(Elab_Body
);
4871 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4873 Set_Handled_Statement_Sequence
(N
,
4874 Make_Handled_Sequence_Of_Statements
(Loc
,
4875 Statements
=> New_List
(Elab_Call
)));
4877 Analyze
(Elab_Call
);
4879 -- Could we reset the scopes of entities associated with the new
4880 -- procedure here via a loop over entities rather than doing it in
4881 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4884 end Check_Unnesting_Elaboration_Code
;
4886 ---------------------------------------
4887 -- Check_Unnesting_In_Decls_Or_Stmts --
4888 ---------------------------------------
4890 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4891 Decl_Or_Stmt
: Node_Id
;
4894 if Unnest_Subprogram_Mode
4895 and then Present
(Decls_Or_Stmts
)
4897 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4898 while Present
(Decl_Or_Stmt
) loop
4899 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4900 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4902 Unnest_Block
(Decl_Or_Stmt
);
4904 -- If-statements may contain subprogram bodies at the outer level
4905 -- of their statement lists, and the subprograms may make up-level
4906 -- references (such as to objects declared in the same statement
4907 -- list). Unlike block and loop cases, however, we don't have an
4908 -- entity on which to test the Contains_Subprogram flag, so
4909 -- Unnest_If_Statement must traverse the statement lists to
4910 -- determine whether there are nested subprograms present.
4912 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4913 Unnest_If_Statement
(Decl_Or_Stmt
);
4915 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4917 Id
: constant Entity_Id
:=
4918 Entity
(Identifier
(Decl_Or_Stmt
));
4921 -- When a top-level loop within declarations of a library
4922 -- package spec or body contains nested subprograms, we wrap
4923 -- it in a procedure to handle possible up-level references
4924 -- to entities associated with the loop (such as loop
4927 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4928 Unnest_Loop
(Decl_Or_Stmt
);
4932 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4933 and then not Modify_Tree_For_C
4935 Check_Unnesting_In_Decls_Or_Stmts
4936 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4937 Check_Unnesting_In_Decls_Or_Stmts
4938 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4940 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4941 and then not Modify_Tree_For_C
4943 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4944 if Present
(Statements
4945 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4947 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4948 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4949 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4953 Next
(Decl_Or_Stmt
);
4956 end Check_Unnesting_In_Decls_Or_Stmts
;
4958 ---------------------------------
4959 -- Check_Unnesting_In_Handlers --
4960 ---------------------------------
4962 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4963 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4966 if Present
(Stmt_Seq
)
4967 and then Present
(Exception_Handlers
(Stmt_Seq
))
4970 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4972 while Present
(Handler
) loop
4973 if Present
(Statements
(Handler
)) then
4974 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4981 end Check_Unnesting_In_Handlers
;
4983 ------------------------------
4984 -- Check_Visibly_Controlled --
4985 ------------------------------
4987 procedure Check_Visibly_Controlled
4988 (Prim
: Final_Primitives
;
4990 E
: in out Entity_Id
;
4991 Cref
: in out Node_Id
)
4993 Parent_Type
: Entity_Id
;
4997 if Is_Derived_Type
(Typ
)
4998 and then Comes_From_Source
(E
)
4999 and then not Present
(Overridden_Operation
(E
))
5001 -- We know that the explicit operation on the type does not override
5002 -- the inherited operation of the parent, and that the derivation
5003 -- is from a private type that is not visibly controlled.
5005 Parent_Type
:= Etype
(Typ
);
5006 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
5008 if Present
(Op
) then
5011 -- Wrap the object to be initialized into the proper
5012 -- unchecked conversion, to be compatible with the operation
5015 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
5016 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
5018 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
5022 end Check_Visibly_Controlled
;
5024 --------------------------
5025 -- Contains_Subprogram --
5026 --------------------------
5028 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
5032 E
:= First_Entity
(Blk
);
5034 while Present
(E
) loop
5035 if Is_Subprogram
(E
) then
5038 elsif Ekind
(E
) in E_Block | E_Loop
5039 and then Contains_Subprogram
(E
)
5048 end Contains_Subprogram
;
5054 function Convert_View
5057 Ind
: Pos
:= 1) return Node_Id
5059 Fent
: Entity_Id
:= First_Entity
(Proc
);
5064 for J
in 2 .. Ind
loop
5068 Ftyp
:= Etype
(Fent
);
5070 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
5071 Atyp
:= Entity
(Subtype_Mark
(Arg
));
5073 Atyp
:= Etype
(Arg
);
5076 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
5077 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
5080 and then Present
(Atyp
)
5081 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
5082 and then Base_Type
(Underlying_Type
(Atyp
)) =
5083 Base_Type
(Underlying_Type
(Ftyp
))
5085 return Unchecked_Convert_To
(Ftyp
, Arg
);
5087 -- If the argument is already a conversion, as generated by
5088 -- Make_Init_Call, set the target type to the type of the formal
5089 -- directly, to avoid spurious typing problems.
5091 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
5092 and then not Is_Class_Wide_Type
(Atyp
)
5094 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
5095 Set_Etype
(Arg
, Ftyp
);
5098 -- Otherwise, introduce a conversion when the designated object
5099 -- has a type derived from the formal of the controlled routine.
5101 elsif Is_Private_Type
(Ftyp
)
5102 and then Present
(Atyp
)
5103 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
5105 return Unchecked_Convert_To
(Ftyp
, Arg
);
5112 ------------------------
5113 -- Enclosing_Function --
5114 ------------------------
5116 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
5117 Func_Id
: Entity_Id
;
5121 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
5122 if Ekind
(Func_Id
) = E_Function
then
5126 Func_Id
:= Scope
(Func_Id
);
5130 end Enclosing_Function
;
5132 -------------------------------
5133 -- Establish_Transient_Scope --
5134 -------------------------------
5136 -- This procedure is called each time a transient block has to be inserted
5137 -- that is to say for each call to a function with unconstrained or tagged
5138 -- result. It creates a new scope on the scope stack in order to enclose
5139 -- all transient variables generated.
5141 procedure Establish_Transient_Scope
5143 Manage_Sec_Stack
: Boolean)
5145 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
5146 -- Determine whether arbitrary Id denotes a package or subprogram [body]
5148 function Find_Enclosing_Transient_Scope
return Entity_Id
;
5149 -- Examine the scope stack looking for the nearest enclosing transient
5150 -- scope within the innermost enclosing package or subprogram. Return
5151 -- Empty if no such scope exists.
5153 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
5154 -- Locate a suitable context for arbitrary node N which may need to be
5155 -- serviced by a transient scope. Return Empty if no suitable context
5158 procedure Delegate_Sec_Stack_Management
;
5159 -- Move the management of the secondary stack to the nearest enclosing
5162 procedure Create_Transient_Scope
(Context
: Node_Id
);
5163 -- Place a new scope on the scope stack in order to service construct
5164 -- Context. Context is the node found by Find_Transient_Context. The
5165 -- new scope may also manage the secondary stack.
5167 ----------------------------
5168 -- Create_Transient_Scope --
5169 ----------------------------
5171 procedure Create_Transient_Scope
(Context
: Node_Id
) is
5172 Loc
: constant Source_Ptr
:= Sloc
(N
);
5174 Iter_Loop
: Entity_Id
;
5175 Trans_Scop
: constant Entity_Id
:=
5176 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
5179 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
5181 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
5184 Push_Scope
(Trans_Scop
);
5185 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
5186 Set_Scope_Is_Transient
;
5188 -- The transient scope must also manage the secondary stack
5190 if Manage_Sec_Stack
then
5191 Set_Uses_Sec_Stack
(Trans_Scop
);
5192 Check_Restriction
(No_Secondary_Stack
, N
);
5194 -- The expansion of iterator loops generates references to objects
5195 -- in order to extract elements from a container:
5197 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
5198 -- Obj : <object type> renames Ref.all.Element.all;
5200 -- These references are controlled and returned on the secondary
5201 -- stack. A new reference is created at each iteration of the loop
5202 -- and as a result it must be finalized and the space occupied by
5203 -- it on the secondary stack reclaimed at the end of the current
5206 -- When the context that requires a transient scope is a call to
5207 -- routine Reference, the node to be wrapped is the source object:
5209 -- for Obj of Container loop
5211 -- Routine Wrap_Transient_Declaration however does not generate
5212 -- a physical block as wrapping a declaration will kill it too
5213 -- early. To handle this peculiar case, mark the related iterator
5214 -- loop as requiring the secondary stack. This signals the
5215 -- finalization machinery to manage the secondary stack (see
5216 -- routine Process_Statements_For_Controlled_Objects).
5218 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
5220 if Present
(Iter_Loop
) then
5221 Set_Uses_Sec_Stack
(Iter_Loop
);
5225 if Debug_Flag_W
then
5226 Write_Str
(" <Transient>");
5229 end Create_Transient_Scope
;
5231 -----------------------------------
5232 -- Delegate_Sec_Stack_Management --
5233 -----------------------------------
5235 procedure Delegate_Sec_Stack_Management
is
5237 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
5239 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
5241 -- Prevent the search from going too far or within the scope
5242 -- space of another unit.
5244 if Scope
.Entity
= Standard_Standard
then
5247 -- No transient scope should be encountered during the
5248 -- traversal because Establish_Transient_Scope should have
5249 -- already handled this case.
5251 elsif Scope
.Is_Transient
then
5252 raise Program_Error
;
5254 -- The construct that requires secondary stack management is
5255 -- always enclosed by a package or subprogram scope.
5257 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
5258 Set_Uses_Sec_Stack
(Scope
.Entity
);
5259 Check_Restriction
(No_Secondary_Stack
, N
);
5266 -- At this point no suitable scope was found. This should never occur
5267 -- because a construct is always enclosed by a compilation unit which
5270 pragma Assert
(False);
5271 end Delegate_Sec_Stack_Management
;
5273 ------------------------------------
5274 -- Find_Enclosing_Transient_Scope --
5275 ------------------------------------
5277 function Find_Enclosing_Transient_Scope
return Entity_Id
is
5279 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
5281 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
5283 -- Prevent the search from going too far or within the scope
5284 -- space of another unit.
5286 if Scope
.Entity
= Standard_Standard
5287 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
5291 elsif Scope
.Is_Transient
then
5292 return Scope
.Entity
;
5298 end Find_Enclosing_Transient_Scope
;
5300 ----------------------------
5301 -- Find_Transient_Context --
5302 ----------------------------
5304 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
5305 Curr
: Node_Id
:= N
;
5306 Prev
: Node_Id
:= Empty
;
5309 while Present
(Curr
) loop
5310 case Nkind
(Curr
) is
5314 -- Declarations act as a boundary for a transient scope even if
5315 -- they are not wrapped, see Wrap_Transient_Declaration.
5317 when N_Object_Declaration
5318 | N_Object_Renaming_Declaration
5319 | N_Subtype_Declaration
5325 -- Statements and statement-like constructs act as a boundary
5326 -- for a transient scope.
5328 when N_Accept_Alternative
5329 | N_Attribute_Definition_Clause
5331 | N_Case_Statement_Alternative
5333 | N_Delay_Alternative
5334 | N_Delay_Until_Statement
5335 | N_Delay_Relative_Statement
5336 | N_Discriminant_Association
5338 | N_Entry_Body_Formal_Part
5341 | N_Iteration_Scheme
5342 | N_Terminate_Alternative
5344 pragma Assert
(Present
(Prev
));
5347 when N_Assignment_Statement
=>
5350 when N_Entry_Call_Statement
5351 | N_Procedure_Call_Statement
5353 -- When an entry or procedure call acts as the alternative
5354 -- of a conditional or timed entry call, the proper context
5355 -- is that of the alternative.
5357 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
5358 and then Nkind
(Parent
(Parent
(Curr
))) in
5359 N_Conditional_Entry_Call | N_Timed_Entry_Call
5361 return Parent
(Parent
(Curr
));
5363 -- General case for entry or procedure calls
5371 -- Pragma Check is not a valid transient context in
5372 -- GNATprove mode because the pragma must remain unchanged.
5375 and then Get_Pragma_Id
(Curr
) = Pragma_Check
5379 -- General case for pragmas
5385 when N_Raise_Statement
=>
5388 when N_Simple_Return_Statement
=>
5390 -- A return statement is not a valid transient context when
5391 -- the function itself requires transient scope management
5392 -- because the result will be reclaimed too early.
5394 if Requires_Transient_Scope
(Etype
5395 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
5399 -- General case for return statements
5407 when N_Attribute_Reference
=>
5408 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
5412 -- An Ada 2012 iterator specification is not a valid context
5413 -- because Analyze_Iterator_Specification already employs
5414 -- special processing for it.
5416 when N_Iterator_Specification
=>
5419 when N_Loop_Parameter_Specification
=>
5421 -- An iteration scheme is not a valid context because
5422 -- routine Analyze_Iteration_Scheme already employs
5423 -- special processing.
5425 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
5428 return Parent
(Curr
);
5433 -- The following nodes represent "dummy contexts" which do not
5434 -- need to be wrapped.
5436 when N_Component_Declaration
5437 | N_Discriminant_Specification
5438 | N_Parameter_Specification
5442 -- If the traversal leaves a scope without having been able to
5443 -- find a construct to wrap, something is going wrong, but this
5444 -- can happen in error situations that are not detected yet
5445 -- (such as a dynamic string in a pragma Export).
5447 when N_Block_Statement
5450 | N_Package_Declaration
5464 Curr
:= Parent
(Curr
);
5468 end Find_Transient_Context
;
5470 ------------------------------
5471 -- Is_Package_Or_Subprogram --
5472 ------------------------------
5474 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
5476 return Ekind
(Id
) in E_Entry
5481 | E_Subprogram_Body
;
5482 end Is_Package_Or_Subprogram
;
5486 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
5489 -- Start of processing for Establish_Transient_Scope
5492 -- Do not create a new transient scope if there is already an enclosing
5493 -- transient scope within the innermost enclosing package or subprogram.
5495 if Present
(Trans_Id
) then
5497 -- If the transient scope was requested for purposes of managing the
5498 -- secondary stack, then the existing scope must perform this task.
5500 if Manage_Sec_Stack
then
5501 Set_Uses_Sec_Stack
(Trans_Id
);
5507 -- Find the construct that must be serviced by a new transient scope, if
5510 Context
:= Find_Transient_Context
(N
);
5512 if Present
(Context
) then
5513 if Nkind
(Context
) = N_Assignment_Statement
then
5515 -- An assignment statement with suppressed controlled semantics
5516 -- does not need a transient scope because finalization is not
5517 -- desirable at this point. Note that No_Ctrl_Actions is also
5518 -- set for non-controlled assignments to suppress dispatching
5521 if No_Ctrl_Actions
(Context
)
5522 and then Needs_Finalization
(Etype
(Name
(Context
)))
5524 -- When a controlled component is initialized by a function
5525 -- call, the result on the secondary stack is always assigned
5526 -- to the component. Signal the nearest suitable scope that it
5527 -- is safe to manage the secondary stack.
5529 if Manage_Sec_Stack
and then Within_Init_Proc
then
5530 Delegate_Sec_Stack_Management
;
5533 -- Otherwise the assignment is a normal transient context and thus
5534 -- requires a transient scope.
5537 Create_Transient_Scope
(Context
);
5543 Create_Transient_Scope
(Context
);
5546 end Establish_Transient_Scope
;
5548 ----------------------------
5549 -- Expand_Cleanup_Actions --
5550 ----------------------------
5552 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
5554 (Nkind
(N
) in N_Block_Statement
5556 | N_Extended_Return_Statement
5560 Scop
: constant Entity_Id
:= Current_Scope
;
5562 Is_Asynchronous_Call
: constant Boolean :=
5563 Nkind
(N
) = N_Block_Statement
5564 and then Is_Asynchronous_Call_Block
(N
);
5565 Is_Master
: constant Boolean :=
5566 Nkind
(N
) /= N_Extended_Return_Statement
5567 and then Nkind
(N
) /= N_Entry_Body
5568 and then Is_Task_Master
(N
);
5569 Is_Protected_Subp_Body
: constant Boolean :=
5570 Nkind
(N
) = N_Subprogram_Body
5571 and then Is_Protected_Subprogram_Body
(N
);
5572 Is_Task_Allocation
: constant Boolean :=
5573 Nkind
(N
) = N_Block_Statement
5574 and then Is_Task_Allocation_Block
(N
);
5575 Is_Task_Body
: constant Boolean :=
5576 Nkind
(Original_Node
(N
)) = N_Task_Body
;
5578 -- We mark the secondary stack if it is used in this construct, and
5579 -- we're not returning a function result on the secondary stack, except
5580 -- that a build-in-place function that might or might not return on the
5581 -- secondary stack always needs a mark. A run-time test is required in
5582 -- the case where the build-in-place function has a BIP_Alloc extra
5583 -- parameter (see Create_Finalizer).
5585 Needs_Sec_Stack_Mark
: constant Boolean :=
5586 (Uses_Sec_Stack
(Scop
)
5588 not Sec_Stack_Needed_For_Return
(Scop
))
5590 (Is_Build_In_Place_Function
(Scop
)
5591 and then Needs_BIP_Alloc_Form
(Scop
));
5593 Needs_Custom_Cleanup
: constant Boolean :=
5594 Nkind
(N
) = N_Block_Statement
5595 and then Present
(Cleanup_Actions
(N
));
5597 Has_Postcondition
: constant Boolean :=
5598 Nkind
(N
) = N_Subprogram_Body
5600 (Postconditions_Proc
5601 (Unique_Defining_Entity
(N
)));
5603 Actions_Required
: constant Boolean :=
5604 Requires_Cleanup_Actions
(N
, True)
5605 or else Is_Asynchronous_Call
5607 or else Is_Protected_Subp_Body
5608 or else Is_Task_Allocation
5609 or else Is_Task_Body
5610 or else Needs_Sec_Stack_Mark
5611 or else Needs_Custom_Cleanup
;
5613 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
5617 procedure Wrap_HSS_In_Block
;
5618 -- Move HSS inside a new block along with the original exception
5619 -- handlers. Make the newly generated block the sole statement of HSS.
5621 -----------------------
5622 -- Wrap_HSS_In_Block --
5623 -----------------------
5625 procedure Wrap_HSS_In_Block
is
5627 Block_Id
: Entity_Id
;
5631 -- Preserve end label to provide proper cross-reference information
5633 End_Lab
:= End_Label
(HSS
);
5635 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
5637 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
5638 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
5639 Set_Etype
(Block_Id
, Standard_Void_Type
);
5640 Set_Block_Node
(Block_Id
, Identifier
(Block
));
5642 -- Signal the finalization machinery that this particular block
5643 -- contains the original context.
5645 Set_Is_Finalization_Wrapper
(Block
);
5647 Set_Handled_Statement_Sequence
(N
,
5648 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
5649 HSS
:= Handled_Statement_Sequence
(N
);
5651 Set_First_Real_Statement
(HSS
, Block
);
5652 Set_End_Label
(HSS
, End_Lab
);
5654 -- Comment needed here, see RH for 1.306 ???
5656 if Nkind
(N
) = N_Subprogram_Body
then
5657 Set_Has_Nested_Block_With_Handler
(Scop
);
5659 end Wrap_HSS_In_Block
;
5661 -- Start of processing for Expand_Cleanup_Actions
5664 -- The current construct does not need any form of servicing
5666 if not Actions_Required
then
5669 -- If the current node is a rewritten task body and the descriptors have
5670 -- not been delayed (due to some nested instantiations), do not generate
5671 -- redundant cleanup actions.
5674 and then Nkind
(N
) = N_Subprogram_Body
5675 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
5680 -- If an extended return statement contains something like
5684 -- where F is a build-in-place function call returning a controlled
5685 -- type, then a temporary object will be implicitly declared as part
5686 -- of the statement list, and this will need cleanup. In such cases,
5689 -- return Result : T := ... do
5690 -- <statements> -- possibly with handlers
5695 -- return Result : T := ... do
5696 -- declare -- no declarations
5698 -- <statements> -- possibly with handlers
5699 -- end; -- no handlers
5702 -- So Expand_Cleanup_Actions will end up being called recursively on the
5705 if Nkind
(N
) = N_Extended_Return_Statement
then
5707 Block
: constant Node_Id
:=
5708 Make_Block_Statement
(Sloc
(N
),
5709 Declarations
=> Empty_List
,
5710 Handled_Statement_Sequence
=>
5711 Handled_Statement_Sequence
(N
));
5713 Set_Handled_Statement_Sequence
(N
,
5714 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
5715 Statements
=> New_List
(Block
)));
5720 -- Analysis of the block did all the work
5725 if Needs_Custom_Cleanup
then
5726 Cln
:= Cleanup_Actions
(N
);
5732 Decls
: List_Id
:= Declarations
(N
);
5734 Mark
: Entity_Id
:= Empty
;
5735 New_Decls
: List_Id
;
5738 -- If we are generating expanded code for debugging purposes, use the
5739 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5740 -- be updated subsequently to reference the proper line in .dg files.
5741 -- If we are not debugging generated code, use No_Location instead,
5742 -- so that no debug information is generated for the cleanup code.
5743 -- This makes the behavior of the NEXT command in GDB monotonic, and
5744 -- makes the placement of breakpoints more accurate.
5746 if Debug_Generated_Code
then
5752 -- A task activation call has already been built for a task
5753 -- allocation block.
5755 if not Is_Task_Allocation
then
5756 Build_Task_Activation_Call
(N
);
5760 Establish_Task_Master
(N
);
5763 New_Decls
:= New_List
;
5765 -- If secondary stack is in use, generate:
5767 -- Mnn : constant Mark_Id := SS_Mark;
5769 if Needs_Sec_Stack_Mark
then
5770 Mark
:= Make_Temporary
(Loc
, 'M');
5772 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
5773 Set_Uses_Sec_Stack
(Scop
, False);
5776 -- If exception handlers are present, wrap the sequence of statements
5777 -- in a block since it is not possible to have exception handlers and
5778 -- an At_End handler in the same construct.
5780 if Present
(Exception_Handlers
(HSS
)) then
5783 -- Ensure that the First_Real_Statement field is set
5785 elsif No
(First_Real_Statement
(HSS
)) then
5786 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
5789 -- Do not move the Activation_Chain declaration in the context of
5790 -- task allocation blocks. Task allocation blocks use _chain in their
5791 -- cleanup handlers and gigi complains if it is declared in the
5792 -- sequence of statements of the scope that declares the handler.
5794 if Is_Task_Allocation
then
5796 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
5800 Decl
:= First
(Decls
);
5801 while Nkind
(Decl
) /= N_Object_Declaration
5802 or else Defining_Identifier
(Decl
) /= Chain
5806 -- A task allocation block should always include a _chain
5809 pragma Assert
(Present
(Decl
));
5813 Prepend_To
(New_Decls
, Decl
);
5817 -- Move the _postconditions subprogram declaration and its associated
5818 -- objects into the declarations section so that it is callable
5819 -- within _postconditions.
5821 if Has_Postcondition
then
5824 Prev_Decl
: Node_Id
;
5828 Prev
(Subprogram_Body
5829 (Postconditions_Proc
(Current_Subprogram
)));
5830 while Present
(Decl
) loop
5831 Prev_Decl
:= Prev
(Decl
);
5834 Prepend_To
(New_Decls
, Decl
);
5836 exit when Nkind
(Decl
) = N_Subprogram_Declaration
5837 and then Chars
(Corresponding_Body
(Decl
))
5838 = Name_uPostconditions
;
5845 -- Ensure the presence of a declaration list in order to successfully
5846 -- append all original statements to it.
5849 Set_Declarations
(N
, New_List
);
5850 Decls
:= Declarations
(N
);
5853 -- Move the declarations into the sequence of statements in order to
5854 -- have them protected by the At_End handler. It may seem weird to
5855 -- put declarations in the sequence of statement but in fact nothing
5856 -- forbids that at the tree level.
5858 Append_List_To
(Decls
, Statements
(HSS
));
5859 Set_Statements
(HSS
, Decls
);
5861 -- Reset the Sloc of the handled statement sequence to properly
5862 -- reflect the new initial "statement" in the sequence.
5864 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
5866 -- The declarations of finalizer spec and auxiliary variables replace
5867 -- the old declarations that have been moved inward.
5869 Set_Declarations
(N
, New_Decls
);
5870 Analyze_Declarations
(New_Decls
);
5872 -- Generate finalization calls for all controlled objects appearing
5873 -- in the statements of N. Add context specific cleanup for various
5878 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5880 Top_Decls
=> New_Decls
,
5881 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5885 if Present
(Fin_Id
) then
5886 Build_Finalizer_Call
(N
, Fin_Id
);
5889 end Expand_Cleanup_Actions
;
5891 ---------------------------
5892 -- Expand_N_Package_Body --
5893 ---------------------------
5895 -- Add call to Activate_Tasks if body is an activator (actual processing
5896 -- is in chapter 9).
5898 -- Generate subprogram descriptor for elaboration routine
5900 -- Encode entity names in package body
5902 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5903 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5907 -- This is done only for non-generic packages
5909 if Ekind
(Spec_Id
) = E_Package
then
5910 Push_Scope
(Spec_Id
);
5912 -- Build dispatch tables of library level tagged types
5914 if Tagged_Type_Expansion
5915 and then Is_Library_Level_Entity
(Spec_Id
)
5917 Build_Static_Dispatch_Tables
(N
);
5920 Expand_CUDA_Package
(N
);
5922 Build_Task_Activation_Call
(N
);
5924 -- Verify the run-time semantics of pragma Initial_Condition at the
5925 -- end of the body statements.
5927 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5929 -- If this is a library-level package and unnesting is enabled,
5930 -- check for the presence of blocks with nested subprograms occurring
5931 -- in elaboration code, and generate procedures to encapsulate the
5932 -- blocks in case the nested subprograms make up-level references.
5934 if Unnest_Subprogram_Mode
5936 Is_Library_Level_Entity
(Current_Scope
)
5938 Check_Unnesting_Elaboration_Code
(N
);
5939 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5940 Check_Unnesting_In_Handlers
(N
);
5946 Set_Elaboration_Flag
(N
, Spec_Id
);
5947 Set_In_Package_Body
(Spec_Id
, False);
5949 -- Set to encode entity names in package body before gigi is called
5951 Qualify_Entity_Names
(N
);
5953 if Ekind
(Spec_Id
) /= E_Generic_Package
then
5956 Clean_Stmts
=> No_List
,
5958 Top_Decls
=> No_List
,
5959 Defer_Abort
=> False,
5962 if Present
(Fin_Id
) then
5964 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
5967 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
5968 Body_Ent
:= Defining_Identifier
(Body_Ent
);
5971 Set_Finalizer
(Body_Ent
, Fin_Id
);
5975 end Expand_N_Package_Body
;
5977 ----------------------------------
5978 -- Expand_N_Package_Declaration --
5979 ----------------------------------
5981 -- Add call to Activate_Tasks if there are tasks declared and the package
5982 -- has no body. Note that in Ada 83 this may result in premature activation
5983 -- of some tasks, given that we cannot tell whether a body will eventually
5986 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5987 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5988 Spec
: constant Node_Id
:= Specification
(N
);
5992 No_Body
: Boolean := False;
5993 -- True in the case of a package declaration that is a compilation
5994 -- unit and for which no associated body will be compiled in this
5998 -- Case of a package declaration other than a compilation unit
6000 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
6003 -- Case of a compilation unit that does not require a body
6005 elsif not Body_Required
(Parent
(N
))
6006 and then not Unit_Requires_Body
(Id
)
6010 -- Special case of generating calling stubs for a remote call interface
6011 -- package: even though the package declaration requires one, the body
6012 -- won't be processed in this compilation (so any stubs for RACWs
6013 -- declared in the package must be generated here, along with the spec).
6015 elsif Parent
(N
) = Cunit
(Main_Unit
)
6016 and then Is_Remote_Call_Interface
(Id
)
6017 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
6022 -- For a nested instance, delay processing until freeze point
6024 if Has_Delayed_Freeze
(Id
)
6025 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
6030 -- For a package declaration that implies no associated body, generate
6031 -- task activation call and RACW supporting bodies now (since we won't
6032 -- have a specific separate compilation unit for that).
6037 -- Generate RACW subprogram bodies
6039 if Has_RACW
(Id
) then
6040 Decls
:= Private_Declarations
(Spec
);
6043 Decls
:= Visible_Declarations
(Spec
);
6048 Set_Visible_Declarations
(Spec
, Decls
);
6051 Append_RACW_Bodies
(Decls
, Id
);
6052 Analyze_List
(Decls
);
6055 -- Generate task activation call as last step of elaboration
6057 if Present
(Activation_Chain_Entity
(N
)) then
6058 Build_Task_Activation_Call
(N
);
6061 -- Verify the run-time semantics of pragma Initial_Condition at the
6062 -- end of the private declarations when the package lacks a body.
6064 Expand_Pragma_Initial_Condition
(Id
, N
);
6069 -- Build dispatch tables of library-level tagged types
6071 if Tagged_Type_Expansion
6072 and then (Is_Compilation_Unit
(Id
)
6073 or else (Is_Generic_Instance
(Id
)
6074 and then Is_Library_Level_Entity
(Id
)))
6076 Build_Static_Dispatch_Tables
(N
);
6079 -- Note: it is not necessary to worry about generating a subprogram
6080 -- descriptor, since the only way to get exception handlers into a
6081 -- package spec is to include instantiations, and that would cause
6082 -- generation of subprogram descriptors to be delayed in any case.
6084 -- Set to encode entity names in package spec before gigi is called
6086 Qualify_Entity_Names
(N
);
6088 if Ekind
(Id
) /= E_Generic_Package
then
6091 Clean_Stmts
=> No_List
,
6093 Top_Decls
=> No_List
,
6094 Defer_Abort
=> False,
6097 Set_Finalizer
(Id
, Fin_Id
);
6100 -- If this is a library-level package and unnesting is enabled,
6101 -- check for the presence of blocks with nested subprograms occurring
6102 -- in elaboration code, and generate procedures to encapsulate the
6103 -- blocks in case the nested subprograms make up-level references.
6105 if Unnest_Subprogram_Mode
6106 and then Is_Library_Level_Entity
(Current_Scope
)
6108 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
6109 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
6111 end Expand_N_Package_Declaration
;
6113 ---------------------------------
6114 -- Has_Simple_Protected_Object --
6115 ---------------------------------
6117 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
6119 if Has_Task
(T
) then
6122 elsif Is_Simple_Protected_Type
(T
) then
6125 elsif Is_Array_Type
(T
) then
6126 return Has_Simple_Protected_Object
(Component_Type
(T
));
6128 elsif Is_Record_Type
(T
) then
6133 Comp
:= First_Component
(T
);
6134 while Present
(Comp
) loop
6135 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
6139 Next_Component
(Comp
);
6148 end Has_Simple_Protected_Object
;
6150 ------------------------------------
6151 -- Insert_Actions_In_Scope_Around --
6152 ------------------------------------
6154 procedure Insert_Actions_In_Scope_Around
6157 Manage_SS
: Boolean)
6159 Act_Before
: constant List_Id
:=
6160 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
6161 Act_After
: constant List_Id
:=
6162 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
6163 Act_Cleanup
: constant List_Id
:=
6164 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
6165 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
6166 -- Last), but this was incorrect as Process_Transients_In_Scope may
6167 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
6169 procedure Process_Transients_In_Scope
6170 (First_Object
: Node_Id
;
6171 Last_Object
: Node_Id
;
6172 Related_Node
: Node_Id
);
6173 -- Find all transient objects in the list First_Object .. Last_Object
6174 -- and generate finalization actions for them. Related_Node denotes the
6175 -- node which created all transient objects.
6177 ---------------------------------
6178 -- Process_Transients_In_Scope --
6179 ---------------------------------
6181 procedure Process_Transients_In_Scope
6182 (First_Object
: Node_Id
;
6183 Last_Object
: Node_Id
;
6184 Related_Node
: Node_Id
)
6186 Must_Hook
: Boolean := False;
6187 -- Flag denoting whether the context requires transient object
6188 -- export to the outer finalizer.
6190 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
6191 -- Determine whether an arbitrary node denotes a subprogram call
6193 procedure Detect_Subprogram_Call
is
6194 new Traverse_Proc
(Is_Subprogram_Call
);
6196 procedure Process_Transient_In_Scope
6197 (Obj_Decl
: Node_Id
;
6198 Blk_Data
: Finalization_Exception_Data
;
6199 Blk_Stmts
: List_Id
);
6200 -- Generate finalization actions for a single transient object
6201 -- denoted by object declaration Obj_Decl. Blk_Data is the
6202 -- exception data of the enclosing block. Blk_Stmts denotes the
6203 -- statements of the enclosing block.
6205 ------------------------
6206 -- Is_Subprogram_Call --
6207 ------------------------
6209 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
6211 -- A regular procedure or function call
6213 if Nkind
(N
) in N_Subprogram_Call
then
6219 -- Heavy expansion may relocate function calls outside the related
6220 -- node. Inspect the original node to detect the initial placement
6223 elsif Is_Rewrite_Substitution
(N
) then
6224 Detect_Subprogram_Call
(Original_Node
(N
));
6232 -- Generalized indexing always involves a function call
6234 elsif Nkind
(N
) = N_Indexed_Component
6235 and then Present
(Generalized_Indexing
(N
))
6245 end Is_Subprogram_Call
;
6247 --------------------------------
6248 -- Process_Transient_In_Scope --
6249 --------------------------------
6251 procedure Process_Transient_In_Scope
6252 (Obj_Decl
: Node_Id
;
6253 Blk_Data
: Finalization_Exception_Data
;
6254 Blk_Stmts
: List_Id
)
6256 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
6257 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
6259 Fin_Stmts
: List_Id
;
6260 Hook_Assign
: Node_Id
;
6261 Hook_Clear
: Node_Id
;
6262 Hook_Decl
: Node_Id
;
6263 Hook_Insert
: Node_Id
;
6267 -- Mark the transient object as successfully processed to avoid
6268 -- double finalization.
6270 Set_Is_Finalized_Transient
(Obj_Id
);
6272 -- Construct all the pieces necessary to hook and finalize the
6273 -- transient object.
6275 Build_Transient_Object_Statements
6276 (Obj_Decl
=> Obj_Decl
,
6277 Fin_Call
=> Fin_Call
,
6278 Hook_Assign
=> Hook_Assign
,
6279 Hook_Clear
=> Hook_Clear
,
6280 Hook_Decl
=> Hook_Decl
,
6281 Ptr_Decl
=> Ptr_Decl
);
6283 -- The context contains at least one subprogram call which may
6284 -- raise an exception. This scenario employs "hooking" to pass
6285 -- transient objects to the enclosing finalizer in case of an
6290 -- Add the access type which provides a reference to the
6291 -- transient object. Generate:
6293 -- type Ptr_Typ is access all Desig_Typ;
6295 Insert_Action
(Obj_Decl
, Ptr_Decl
);
6297 -- Add the temporary which acts as a hook to the transient
6298 -- object. Generate:
6300 -- Hook : Ptr_Typ := null;
6302 Insert_Action
(Obj_Decl
, Hook_Decl
);
6304 -- When the transient object is initialized by an aggregate,
6305 -- the hook must capture the object after the last aggregate
6306 -- assignment takes place. Only then is the object considered
6307 -- fully initialized. Generate:
6309 -- Hook := Ptr_Typ (Obj_Id);
6311 -- Hook := Obj_Id'Unrestricted_Access;
6313 -- Similarly if we have a build in place call: we must
6314 -- initialize Hook only after the call has happened, otherwise
6315 -- Obj_Id will not be initialized yet.
6317 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
6318 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
6319 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
6320 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
6321 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
6323 Hook_Insert
:= Obj_Decl
;
6326 -- Otherwise the hook seizes the related object immediately
6329 Hook_Insert
:= Obj_Decl
;
6332 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
6335 -- When exception propagation is enabled wrap the hook clear
6336 -- statement and the finalization call into a block to catch
6337 -- potential exceptions raised during finalization. Generate:
6341 -- [Deep_]Finalize (Obj_Ref);
6345 -- if not Raised then
6348 -- (Enn, Get_Current_Excep.all.all);
6352 if Exceptions_OK
then
6353 Fin_Stmts
:= New_List
;
6356 Append_To
(Fin_Stmts
, Hook_Clear
);
6359 Append_To
(Fin_Stmts
, Fin_Call
);
6361 Prepend_To
(Blk_Stmts
,
6362 Make_Block_Statement
(Loc
,
6363 Handled_Statement_Sequence
=>
6364 Make_Handled_Sequence_Of_Statements
(Loc
,
6365 Statements
=> Fin_Stmts
,
6366 Exception_Handlers
=> New_List
(
6367 Build_Exception_Handler
(Blk_Data
)))));
6369 -- Otherwise generate:
6372 -- [Deep_]Finalize (Obj_Ref);
6374 -- Note that the statements are inserted in reverse order to
6375 -- achieve the desired final order outlined above.
6378 Prepend_To
(Blk_Stmts
, Fin_Call
);
6381 Prepend_To
(Blk_Stmts
, Hook_Clear
);
6384 end Process_Transient_In_Scope
;
6388 Built
: Boolean := False;
6389 Blk_Data
: Finalization_Exception_Data
;
6390 Blk_Decl
: Node_Id
:= Empty
;
6391 Blk_Decls
: List_Id
:= No_List
;
6393 Blk_Stmts
: List_Id
:= No_List
;
6394 Loc
: Source_Ptr
:= No_Location
;
6397 -- Start of processing for Process_Transients_In_Scope
6400 -- The expansion performed by this routine is as follows:
6402 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
6403 -- Hook_1 : Ptr_Typ_1 := null;
6404 -- Ctrl_Trans_Obj_1 : ...;
6405 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
6407 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
6408 -- Hook_N : Ptr_Typ_N := null;
6409 -- Ctrl_Trans_Obj_N : ...;
6410 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
6413 -- Abrt : constant Boolean := ...;
6414 -- Ex : Exception_Occurrence;
6415 -- Raised : Boolean := False;
6422 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
6426 -- if not Raised then
6428 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6433 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
6437 -- if not Raised then
6439 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6444 -- if Raised and not Abrt then
6445 -- Raise_From_Controlled_Operation (Ex);
6449 -- Recognize a scenario where the transient context is an object
6450 -- declaration initialized by a build-in-place function call:
6452 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
6454 -- The rough expansion of the above is:
6456 -- Temp : ... := Ctrl_Func_Call;
6458 -- Res : ... := BIP_Func_Call (..., Obj, ...);
6460 -- The finalization of any transient object must happen after the
6461 -- build-in-place function call is executed.
6463 if Nkind
(N
) = N_Object_Declaration
6464 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
6467 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
6469 -- Search the context for at least one subprogram call. If found, the
6470 -- machinery exports all transient objects to the enclosing finalizer
6471 -- due to the possibility of abnormal call termination.
6474 Detect_Subprogram_Call
(N
);
6475 Blk_Ins
:= Last_Object
;
6479 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
6482 -- Examine all objects in the list First_Object .. Last_Object
6484 Obj_Decl
:= First_Object
;
6485 while Present
(Obj_Decl
) loop
6486 if Nkind
(Obj_Decl
) = N_Object_Declaration
6487 and then Analyzed
(Obj_Decl
)
6488 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
6490 -- Do not process the node to be wrapped since it will be
6491 -- handled by the enclosing finalizer.
6493 and then Obj_Decl
/= Related_Node
6495 Loc
:= Sloc
(Obj_Decl
);
6497 -- Before generating the cleanup code for the first transient
6498 -- object, create a wrapper block which houses all hook clear
6499 -- statements and finalization calls. This wrapper is needed by
6504 Blk_Stmts
:= New_List
;
6507 -- Abrt : constant Boolean := ...;
6508 -- Ex : Exception_Occurrence;
6509 -- Raised : Boolean := False;
6511 if Exceptions_OK
then
6512 Blk_Decls
:= New_List
;
6513 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
6517 Make_Block_Statement
(Loc
,
6518 Declarations
=> Blk_Decls
,
6519 Handled_Statement_Sequence
=>
6520 Make_Handled_Sequence_Of_Statements
(Loc
,
6521 Statements
=> Blk_Stmts
));
6524 -- Construct all necessary circuitry to hook and finalize a
6525 -- single transient object.
6527 pragma Assert
(Present
(Blk_Stmts
));
6528 Process_Transient_In_Scope
6529 (Obj_Decl
=> Obj_Decl
,
6530 Blk_Data
=> Blk_Data
,
6531 Blk_Stmts
=> Blk_Stmts
);
6534 -- Terminate the scan after the last object has been processed to
6535 -- avoid touching unrelated code.
6537 if Obj_Decl
= Last_Object
then
6544 -- Complete the decoration of the enclosing finalization block and
6545 -- insert it into the tree.
6547 if Present
(Blk_Decl
) then
6549 pragma Assert
(Present
(Blk_Stmts
));
6550 pragma Assert
(Loc
/= No_Location
);
6552 -- Note that this Abort_Undefer does not require a extra block or
6553 -- an AT_END handler because each finalization exception is caught
6554 -- in its own corresponding finalization block. As a result, the
6555 -- call to Abort_Defer always takes place.
6557 if Abort_Allowed
then
6558 Prepend_To
(Blk_Stmts
,
6559 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
6561 Append_To
(Blk_Stmts
,
6562 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
6566 -- if Raised and then not Abrt then
6567 -- Raise_From_Controlled_Operation (Ex);
6570 if Exceptions_OK
then
6571 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
6574 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
6576 end Process_Transients_In_Scope
;
6580 Loc
: constant Source_Ptr
:= Sloc
(N
);
6581 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
6582 First_Obj
: Node_Id
;
6584 Mark_Id
: Entity_Id
;
6587 -- Start of processing for Insert_Actions_In_Scope_Around
6590 -- Nothing to do if the scope does not manage the secondary stack or
6591 -- does not contain meaningful actions for insertion.
6594 and then No
(Act_Before
)
6595 and then No
(Act_After
)
6596 and then No
(Act_Cleanup
)
6601 -- If the node to be wrapped is the trigger of an asynchronous select,
6602 -- it is not part of a statement list. The actions must be inserted
6603 -- before the select itself, which is part of some list of statements.
6604 -- Note that the triggering alternative includes the triggering
6605 -- statement and an optional statement list. If the node to be
6606 -- wrapped is part of that list, the normal insertion applies.
6608 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
6609 and then not Is_List_Member
(Node_To_Wrap
)
6611 Target
:= Parent
(Parent
(Node_To_Wrap
));
6616 First_Obj
:= Target
;
6619 -- Add all actions associated with a transient scope into the main tree.
6620 -- There are several scenarios here:
6622 -- +--- Before ----+ +----- After ---+
6623 -- 1) First_Obj ....... Target ........ Last_Obj
6625 -- 2) First_Obj ....... Target
6627 -- 3) Target ........ Last_Obj
6629 -- Flag declarations are inserted before the first object
6631 if Present
(Act_Before
) then
6632 First_Obj
:= First
(Act_Before
);
6633 Insert_List_Before
(Target
, Act_Before
);
6636 -- Finalization calls are inserted after the last object
6638 if Present
(Act_After
) then
6639 Last_Obj
:= Last
(Act_After
);
6640 Insert_List_After
(Target
, Act_After
);
6643 -- Mark and release the secondary stack when the context warrants it
6646 Mark_Id
:= Make_Temporary
(Loc
, 'M');
6649 -- Mnn : constant Mark_Id := SS_Mark;
6651 Insert_Before_And_Analyze
6652 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
6655 -- SS_Release (Mnn);
6657 Insert_After_And_Analyze
6658 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
6661 -- Check for transient objects associated with Target and generate the
6662 -- appropriate finalization actions for them.
6664 Process_Transients_In_Scope
6665 (First_Object
=> First_Obj
,
6666 Last_Object
=> Last_Obj
,
6667 Related_Node
=> Target
);
6669 -- Reset the action lists
6672 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
6674 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
6678 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
6680 end Insert_Actions_In_Scope_Around
;
6682 ------------------------------
6683 -- Is_Simple_Protected_Type --
6684 ------------------------------
6686 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
6689 Is_Protected_Type
(T
)
6690 and then not Uses_Lock_Free
(T
)
6691 and then not Has_Entries
(T
)
6692 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
6693 end Is_Simple_Protected_Type
;
6695 -----------------------
6696 -- Make_Adjust_Call --
6697 -----------------------
6699 function Make_Adjust_Call
6702 Skip_Self
: Boolean := False) return Node_Id
6704 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
6705 Adj_Id
: Entity_Id
:= Empty
;
6712 -- Recover the proper type which contains Deep_Adjust
6714 if Is_Class_Wide_Type
(Typ
) then
6715 Utyp
:= Root_Type
(Typ
);
6720 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
6721 Set_Assignment_OK
(Ref
);
6723 -- Deal with untagged derivation of private views
6725 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
6726 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6727 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6728 Set_Assignment_OK
(Ref
);
6731 -- When dealing with the completion of a private type, use the base
6734 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
6735 pragma Assert
(Is_Private_Type
(Typ
));
6737 Utyp
:= Base_Type
(Utyp
);
6738 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6741 -- The underlying type may not be present due to a missing full view. In
6742 -- this case freezing did not take place and there is no [Deep_]Adjust
6743 -- primitive to call.
6748 elsif Skip_Self
then
6749 if Has_Controlled_Component
(Utyp
) then
6750 if Is_Tagged_Type
(Utyp
) then
6751 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6753 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6757 -- Class-wide types, interfaces and types with controlled components
6759 elsif Is_Class_Wide_Type
(Typ
)
6760 or else Is_Interface
(Typ
)
6761 or else Has_Controlled_Component
(Utyp
)
6763 if Is_Tagged_Type
(Utyp
) then
6764 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6766 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6769 -- Derivations from [Limited_]Controlled
6771 elsif Is_Controlled
(Utyp
) then
6772 if Has_Controlled_Component
(Utyp
) then
6773 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6775 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
6780 elsif Is_Tagged_Type
(Utyp
) then
6781 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6784 raise Program_Error
;
6787 if Present
(Adj_Id
) then
6789 -- If the object is unanalyzed, set its expected type for use in
6790 -- Convert_View in case an additional conversion is needed.
6793 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
6795 Set_Etype
(Ref
, Typ
);
6798 -- The object reference may need another conversion depending on the
6799 -- type of the formal and that of the actual.
6801 if not Is_Class_Wide_Type
(Typ
) then
6802 Ref
:= Convert_View
(Adj_Id
, Ref
);
6809 Skip_Self
=> Skip_Self
);
6813 end Make_Adjust_Call
;
6821 Proc_Id
: Entity_Id
;
6823 Skip_Self
: Boolean := False) return Node_Id
6825 Params
: constant List_Id
:= New_List
(Param
);
6828 -- Do not apply the controlled action to the object itself by signaling
6829 -- the related routine to avoid self.
6832 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6836 Make_Procedure_Call_Statement
(Loc
,
6837 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6838 Parameter_Associations
=> Params
);
6841 --------------------------
6842 -- Make_Deep_Array_Body --
6843 --------------------------
6845 function Make_Deep_Array_Body
6846 (Prim
: Final_Primitives
;
6847 Typ
: Entity_Id
) return List_Id
6849 function Build_Adjust_Or_Finalize_Statements
6850 (Typ
: Entity_Id
) return List_Id
;
6851 -- Create the statements necessary to adjust or finalize an array of
6852 -- controlled elements. Generate:
6855 -- Abort : constant Boolean := Triggered_By_Abort;
6857 -- Abort : constant Boolean := False; -- no abort
6859 -- E : Exception_Occurrence;
6860 -- Raised : Boolean := False;
6863 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6864 -- ^-- in the finalization case
6866 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6868 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6872 -- if not Raised then
6874 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6881 -- if Raised and then not Abort then
6882 -- Raise_From_Controlled_Operation (E);
6886 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6887 -- Create the statements necessary to initialize an array of controlled
6888 -- elements. Include a mechanism to carry out partial finalization if an
6889 -- exception occurs. Generate:
6892 -- Counter : Integer := 0;
6895 -- for J1 in V'Range (1) loop
6897 -- for JN in V'Range (N) loop
6899 -- [Deep_]Initialize (V (J1, ..., JN));
6901 -- Counter := Counter + 1;
6906 -- Abort : constant Boolean := Triggered_By_Abort;
6908 -- Abort : constant Boolean := False; -- no abort
6909 -- E : Exception_Occurrence;
6910 -- Raised : Boolean := False;
6917 -- V'Length (N) - Counter;
6919 -- for F1 in reverse V'Range (1) loop
6921 -- for FN in reverse V'Range (N) loop
6922 -- if Counter > 0 then
6923 -- Counter := Counter - 1;
6926 -- [Deep_]Finalize (V (F1, ..., FN));
6930 -- if not Raised then
6932 -- Save_Occurrence (E,
6933 -- Get_Current_Excep.all.all);
6942 -- if Raised and then not Abort then
6943 -- Raise_From_Controlled_Operation (E);
6952 function New_References_To
6954 Loc
: Source_Ptr
) return List_Id
;
6955 -- Given a list of defining identifiers, return a list of references to
6956 -- the original identifiers, in the same order as they appear.
6958 -----------------------------------------
6959 -- Build_Adjust_Or_Finalize_Statements --
6960 -----------------------------------------
6962 function Build_Adjust_Or_Finalize_Statements
6963 (Typ
: Entity_Id
) return List_Id
6965 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6966 Index_List
: constant List_Id
:= New_List
;
6967 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6968 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6970 procedure Build_Indexes
;
6971 -- Generate the indexes used in the dimension loops
6977 procedure Build_Indexes
is
6979 -- Generate the following identifiers:
6980 -- Jnn - for initialization
6982 for Dim
in 1 .. Num_Dims
loop
6983 Append_To
(Index_List
,
6984 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6990 Final_Decls
: List_Id
:= No_List
;
6991 Final_Data
: Finalization_Exception_Data
;
6995 Core_Loop
: Node_Id
;
6998 Loop_Id
: Entity_Id
;
7001 -- Start of processing for Build_Adjust_Or_Finalize_Statements
7004 Final_Decls
:= New_List
;
7007 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
7010 Make_Indexed_Component
(Loc
,
7011 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7012 Expressions
=> New_References_To
(Index_List
, Loc
));
7013 Set_Etype
(Comp_Ref
, Comp_Typ
);
7016 -- [Deep_]Adjust (V (J1, ..., JN))
7018 if Prim
= Adjust_Case
then
7019 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
7022 -- [Deep_]Finalize (V (J1, ..., JN))
7024 else pragma Assert
(Prim
= Finalize_Case
);
7025 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
7028 if Present
(Call
) then
7030 -- Generate the block which houses the adjust or finalize call:
7033 -- <adjust or finalize call>
7037 -- if not Raised then
7039 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7043 if Exceptions_OK
then
7045 Make_Block_Statement
(Loc
,
7046 Handled_Statement_Sequence
=>
7047 Make_Handled_Sequence_Of_Statements
(Loc
,
7048 Statements
=> New_List
(Call
),
7049 Exception_Handlers
=> New_List
(
7050 Build_Exception_Handler
(Final_Data
))));
7055 -- Generate the dimension loops starting from the innermost one
7057 -- for Jnn in [reverse] V'Range (Dim) loop
7061 J
:= Last
(Index_List
);
7063 while Present
(J
) and then Dim
> 0 loop
7069 Make_Loop_Statement
(Loc
,
7071 Make_Iteration_Scheme
(Loc
,
7072 Loop_Parameter_Specification
=>
7073 Make_Loop_Parameter_Specification
(Loc
,
7074 Defining_Identifier
=> Loop_Id
,
7075 Discrete_Subtype_Definition
=>
7076 Make_Attribute_Reference
(Loc
,
7077 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7078 Attribute_Name
=> Name_Range
,
7079 Expressions
=> New_List
(
7080 Make_Integer_Literal
(Loc
, Dim
))),
7083 Prim
= Finalize_Case
)),
7085 Statements
=> New_List
(Core_Loop
),
7086 End_Label
=> Empty
);
7091 -- Generate the block which contains the core loop, declarations
7092 -- of the abort flag, the exception occurrence, the raised flag
7093 -- and the conditional raise:
7096 -- Abort : constant Boolean := Triggered_By_Abort;
7098 -- Abort : constant Boolean := False; -- no abort
7100 -- E : Exception_Occurrence;
7101 -- Raised : Boolean := False;
7106 -- if Raised and then not Abort then
7107 -- Raise_From_Controlled_Operation (E);
7111 Stmts
:= New_List
(Core_Loop
);
7113 if Exceptions_OK
then
7114 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
7118 Make_Block_Statement
(Loc
,
7119 Declarations
=> Final_Decls
,
7120 Handled_Statement_Sequence
=>
7121 Make_Handled_Sequence_Of_Statements
(Loc
,
7122 Statements
=> Stmts
));
7124 -- Otherwise previous errors or a missing full view may prevent the
7125 -- proper freezing of the component type. If this is the case, there
7126 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
7129 Block
:= Make_Null_Statement
(Loc
);
7132 return New_List
(Block
);
7133 end Build_Adjust_Or_Finalize_Statements
;
7135 ---------------------------------
7136 -- Build_Initialize_Statements --
7137 ---------------------------------
7139 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
7140 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
7141 Final_List
: constant List_Id
:= New_List
;
7142 Index_List
: constant List_Id
:= New_List
;
7143 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7144 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
7146 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
7147 -- Generate the following assignment:
7148 -- Counter := V'Length (1) *
7150 -- V'Length (N) - Counter;
7152 -- Counter_Id denotes the entity of the counter.
7154 function Build_Finalization_Call
return Node_Id
;
7155 -- Generate a deep finalization call for an array element
7157 procedure Build_Indexes
;
7158 -- Generate the initialization and finalization indexes used in the
7161 function Build_Initialization_Call
return Node_Id
;
7162 -- Generate a deep initialization call for an array element
7164 ----------------------
7165 -- Build_Assignment --
7166 ----------------------
7168 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
7173 -- Start from the first dimension and generate:
7178 Make_Attribute_Reference
(Loc
,
7179 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7180 Attribute_Name
=> Name_Length
,
7181 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
7183 -- Process the rest of the dimensions, generate:
7184 -- Expr * V'Length (N)
7187 while Dim
<= Num_Dims
loop
7189 Make_Op_Multiply
(Loc
,
7192 Make_Attribute_Reference
(Loc
,
7193 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7194 Attribute_Name
=> Name_Length
,
7195 Expressions
=> New_List
(
7196 Make_Integer_Literal
(Loc
, Dim
))));
7202 -- Counter := Expr - Counter;
7205 Make_Assignment_Statement
(Loc
,
7206 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7208 Make_Op_Subtract
(Loc
,
7210 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
7211 end Build_Assignment
;
7213 -----------------------------
7214 -- Build_Finalization_Call --
7215 -----------------------------
7217 function Build_Finalization_Call
return Node_Id
is
7218 Comp_Ref
: constant Node_Id
:=
7219 Make_Indexed_Component
(Loc
,
7220 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7221 Expressions
=> New_References_To
(Final_List
, Loc
));
7224 Set_Etype
(Comp_Ref
, Comp_Typ
);
7227 -- [Deep_]Finalize (V);
7229 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
7230 end Build_Finalization_Call
;
7236 procedure Build_Indexes
is
7238 -- Generate the following identifiers:
7239 -- Jnn - for initialization
7240 -- Fnn - for finalization
7242 for Dim
in 1 .. Num_Dims
loop
7243 Append_To
(Index_List
,
7244 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
7246 Append_To
(Final_List
,
7247 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
7251 -------------------------------
7252 -- Build_Initialization_Call --
7253 -------------------------------
7255 function Build_Initialization_Call
return Node_Id
is
7256 Comp_Ref
: constant Node_Id
:=
7257 Make_Indexed_Component
(Loc
,
7258 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7259 Expressions
=> New_References_To
(Index_List
, Loc
));
7262 Set_Etype
(Comp_Ref
, Comp_Typ
);
7265 -- [Deep_]Initialize (V (J1, ..., JN));
7267 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
7268 end Build_Initialization_Call
;
7272 Counter_Id
: Entity_Id
;
7276 Final_Block
: Node_Id
;
7277 Final_Data
: Finalization_Exception_Data
;
7278 Final_Decls
: List_Id
:= No_List
;
7279 Final_Loop
: Node_Id
;
7280 Init_Block
: Node_Id
;
7281 Init_Call
: Node_Id
;
7282 Init_Loop
: Node_Id
;
7287 -- Start of processing for Build_Initialize_Statements
7290 Counter_Id
:= Make_Temporary
(Loc
, 'C');
7291 Final_Decls
:= New_List
;
7294 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
7296 -- Generate the block which houses the finalization call, the index
7297 -- guard and the handler which triggers Program_Error later on.
7299 -- if Counter > 0 then
7300 -- Counter := Counter - 1;
7303 -- [Deep_]Finalize (V (F1, ..., FN));
7306 -- if not Raised then
7308 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7313 Fin_Stmt
:= Build_Finalization_Call
;
7315 if Present
(Fin_Stmt
) then
7316 if Exceptions_OK
then
7318 Make_Block_Statement
(Loc
,
7319 Handled_Statement_Sequence
=>
7320 Make_Handled_Sequence_Of_Statements
(Loc
,
7321 Statements
=> New_List
(Fin_Stmt
),
7322 Exception_Handlers
=> New_List
(
7323 Build_Exception_Handler
(Final_Data
))));
7326 -- This is the core of the loop, the dimension iterators are added
7327 -- one by one in reverse.
7330 Make_If_Statement
(Loc
,
7333 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7334 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
7336 Then_Statements
=> New_List
(
7337 Make_Assignment_Statement
(Loc
,
7338 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7340 Make_Op_Subtract
(Loc
,
7341 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7342 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
7344 Else_Statements
=> New_List
(Fin_Stmt
));
7346 -- Generate all finalization loops starting from the innermost
7349 -- for Fnn in reverse V'Range (Dim) loop
7353 F
:= Last
(Final_List
);
7355 while Present
(F
) and then Dim
> 0 loop
7361 Make_Loop_Statement
(Loc
,
7363 Make_Iteration_Scheme
(Loc
,
7364 Loop_Parameter_Specification
=>
7365 Make_Loop_Parameter_Specification
(Loc
,
7366 Defining_Identifier
=> Loop_Id
,
7367 Discrete_Subtype_Definition
=>
7368 Make_Attribute_Reference
(Loc
,
7369 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7370 Attribute_Name
=> Name_Range
,
7371 Expressions
=> New_List
(
7372 Make_Integer_Literal
(Loc
, Dim
))),
7374 Reverse_Present
=> True)),
7376 Statements
=> New_List
(Final_Loop
),
7377 End_Label
=> Empty
);
7382 -- Generate the block which contains the finalization loops, the
7383 -- declarations of the abort flag, the exception occurrence, the
7384 -- raised flag and the conditional raise.
7387 -- Abort : constant Boolean := Triggered_By_Abort;
7389 -- Abort : constant Boolean := False; -- no abort
7391 -- E : Exception_Occurrence;
7392 -- Raised : Boolean := False;
7398 -- V'Length (N) - Counter;
7402 -- if Raised and then not Abort then
7403 -- Raise_From_Controlled_Operation (E);
7409 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
7411 if Exceptions_OK
then
7412 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
7413 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
7417 Make_Block_Statement
(Loc
,
7418 Declarations
=> Final_Decls
,
7419 Handled_Statement_Sequence
=>
7420 Make_Handled_Sequence_Of_Statements
(Loc
,
7421 Statements
=> Stmts
));
7423 -- Otherwise previous errors or a missing full view may prevent the
7424 -- proper freezing of the component type. If this is the case, there
7425 -- is no [Deep_]Finalize primitive to call.
7428 Final_Block
:= Make_Null_Statement
(Loc
);
7431 -- Generate the block which contains the initialization call and
7432 -- the partial finalization code.
7435 -- [Deep_]Initialize (V (J1, ..., JN));
7437 -- Counter := Counter + 1;
7441 -- <finalization code>
7444 Init_Call
:= Build_Initialization_Call
;
7446 -- Only create finalization block if there is a nontrivial call
7447 -- to initialization or a Default_Initial_Condition check to be
7450 if (Present
(Init_Call
)
7451 and then Nkind
(Init_Call
) /= N_Null_Statement
)
7454 and then not GNATprove_Mode
7455 and then Present
(DIC_Procedure
(Comp_Typ
))
7456 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
7459 Init_Stmts
: constant List_Id
:= New_List
;
7462 if Present
(Init_Call
) then
7463 Append_To
(Init_Stmts
, Init_Call
);
7466 if Has_DIC
(Comp_Typ
)
7467 and then Present
(DIC_Procedure
(Comp_Typ
))
7471 Build_DIC_Call
(Loc
,
7472 Make_Indexed_Component
(Loc
,
7473 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7474 Expressions
=> New_References_To
(Index_List
, Loc
)),
7479 Make_Block_Statement
(Loc
,
7480 Handled_Statement_Sequence
=>
7481 Make_Handled_Sequence_Of_Statements
(Loc
,
7482 Statements
=> Init_Stmts
,
7483 Exception_Handlers
=> New_List
(
7484 Make_Exception_Handler
(Loc
,
7485 Exception_Choices
=> New_List
(
7486 Make_Others_Choice
(Loc
)),
7487 Statements
=> New_List
(Final_Block
)))));
7490 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
7491 Make_Assignment_Statement
(Loc
,
7492 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7495 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7496 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
7498 -- Generate all initialization loops starting from the innermost
7501 -- for Jnn in V'Range (Dim) loop
7505 J
:= Last
(Index_List
);
7507 while Present
(J
) and then Dim
> 0 loop
7513 Make_Loop_Statement
(Loc
,
7515 Make_Iteration_Scheme
(Loc
,
7516 Loop_Parameter_Specification
=>
7517 Make_Loop_Parameter_Specification
(Loc
,
7518 Defining_Identifier
=> Loop_Id
,
7519 Discrete_Subtype_Definition
=>
7520 Make_Attribute_Reference
(Loc
,
7521 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7522 Attribute_Name
=> Name_Range
,
7523 Expressions
=> New_List
(
7524 Make_Integer_Literal
(Loc
, Dim
))))),
7526 Statements
=> New_List
(Init_Loop
),
7527 End_Label
=> Empty
);
7532 -- Generate the block which contains the counter variable and the
7533 -- initialization loops.
7536 -- Counter : Integer := 0;
7542 Make_Block_Statement
(Loc
,
7543 Declarations
=> New_List
(
7544 Make_Object_Declaration
(Loc
,
7545 Defining_Identifier
=> Counter_Id
,
7546 Object_Definition
=>
7547 New_Occurrence_Of
(Standard_Integer
, Loc
),
7548 Expression
=> Make_Integer_Literal
(Loc
, 0))),
7550 Handled_Statement_Sequence
=>
7551 Make_Handled_Sequence_Of_Statements
(Loc
,
7552 Statements
=> New_List
(Init_Loop
)));
7554 if Debug_Generated_Code
then
7555 Set_Debug_Info_Needed
(Counter_Id
);
7558 -- Otherwise previous errors or a missing full view may prevent the
7559 -- proper freezing of the component type. If this is the case, there
7560 -- is no [Deep_]Initialize primitive to call.
7563 Init_Block
:= Make_Null_Statement
(Loc
);
7566 return New_List
(Init_Block
);
7567 end Build_Initialize_Statements
;
7569 -----------------------
7570 -- New_References_To --
7571 -----------------------
7573 function New_References_To
7575 Loc
: Source_Ptr
) return List_Id
7577 Refs
: constant List_Id
:= New_List
;
7582 while Present
(Id
) loop
7583 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
7588 end New_References_To
;
7590 -- Start of processing for Make_Deep_Array_Body
7594 when Address_Case
=>
7595 return Make_Finalize_Address_Stmts
(Typ
);
7600 return Build_Adjust_Or_Finalize_Statements
(Typ
);
7602 when Initialize_Case
=>
7603 return Build_Initialize_Statements
(Typ
);
7605 end Make_Deep_Array_Body
;
7607 --------------------
7608 -- Make_Deep_Proc --
7609 --------------------
7611 function Make_Deep_Proc
7612 (Prim
: Final_Primitives
;
7614 Stmts
: List_Id
) return Entity_Id
7616 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7618 Proc_Id
: Entity_Id
;
7621 -- Create the object formal, generate:
7622 -- V : System.Address
7624 if Prim
= Address_Case
then
7625 Formals
:= New_List
(
7626 Make_Parameter_Specification
(Loc
,
7627 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7629 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7636 Formals
:= New_List
(
7637 Make_Parameter_Specification
(Loc
,
7638 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7640 Out_Present
=> True,
7641 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
7643 -- F : Boolean := True
7645 if Prim
= Adjust_Case
7646 or else Prim
= Finalize_Case
7649 Make_Parameter_Specification
(Loc
,
7650 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7652 New_Occurrence_Of
(Standard_Boolean
, Loc
),
7654 New_Occurrence_Of
(Standard_True
, Loc
)));
7659 Make_Defining_Identifier
(Loc
,
7660 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
7663 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
7666 -- exception -- Finalize and Adjust cases only
7667 -- raise Program_Error;
7668 -- end Deep_Initialize / Adjust / Finalize;
7672 -- procedure Finalize_Address (V : System.Address) is
7675 -- end Finalize_Address;
7678 Make_Subprogram_Body
(Loc
,
7680 Make_Procedure_Specification
(Loc
,
7681 Defining_Unit_Name
=> Proc_Id
,
7682 Parameter_Specifications
=> Formals
),
7684 Declarations
=> Empty_List
,
7686 Handled_Statement_Sequence
=>
7687 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
7689 -- If there are no calls to component initialization, indicate that
7690 -- the procedure is trivial, so prevent calls to it.
7692 if Is_Empty_List
(Stmts
)
7693 or else Nkind
(First
(Stmts
)) = N_Null_Statement
7695 Set_Is_Trivial_Subprogram
(Proc_Id
);
7701 ---------------------------
7702 -- Make_Deep_Record_Body --
7703 ---------------------------
7705 function Make_Deep_Record_Body
7706 (Prim
: Final_Primitives
;
7708 Is_Local
: Boolean := False) return List_Id
7710 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
7711 -- Build the statements necessary to adjust a record type. The type may
7712 -- have discriminants and contain variant parts. Generate:
7716 -- [Deep_]Adjust (V.Comp_1);
7718 -- when Id : others =>
7719 -- if not Raised then
7721 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7726 -- [Deep_]Adjust (V.Comp_N);
7728 -- when Id : others =>
7729 -- if not Raised then
7731 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7736 -- Deep_Adjust (V._parent, False); -- If applicable
7738 -- when Id : others =>
7739 -- if not Raised then
7741 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7747 -- Adjust (V); -- If applicable
7750 -- if not Raised then
7752 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7757 -- if Raised and then not Abort then
7758 -- Raise_From_Controlled_Operation (E);
7762 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
7763 -- Build the statements necessary to finalize a record type. The type
7764 -- may have discriminants and contain variant parts. Generate:
7767 -- Abort : constant Boolean := Triggered_By_Abort;
7769 -- Abort : constant Boolean := False; -- no abort
7770 -- E : Exception_Occurrence;
7771 -- Raised : Boolean := False;
7776 -- Finalize (V); -- If applicable
7779 -- if not Raised then
7781 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7786 -- case Variant_1 is
7788 -- case State_Counter_N => -- If Is_Local is enabled
7798 -- <<LN>> -- If Is_Local is enabled
7800 -- [Deep_]Finalize (V.Comp_N);
7803 -- if not Raised then
7805 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7811 -- [Deep_]Finalize (V.Comp_1);
7814 -- if not Raised then
7816 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7822 -- case State_Counter_1 => -- If Is_Local is enabled
7828 -- Deep_Finalize (V._parent, False); -- If applicable
7830 -- when Id : others =>
7831 -- if not Raised then
7833 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7837 -- if Raised and then not Abort then
7838 -- Raise_From_Controlled_Operation (E);
7842 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7843 -- Given a derived tagged type Typ, traverse all components, find field
7844 -- _parent and return its type.
7846 procedure Preprocess_Components
7848 Num_Comps
: out Nat
;
7849 Has_POC
: out Boolean);
7850 -- Examine all components in component list Comps, count all controlled
7851 -- components and determine whether at least one of them is per-object
7852 -- constrained. Component _parent is always skipped.
7854 -----------------------------
7855 -- Build_Adjust_Statements --
7856 -----------------------------
7858 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7859 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7860 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7862 Finalizer_Data
: Finalization_Exception_Data
;
7864 function Process_Component_List_For_Adjust
7865 (Comps
: Node_Id
) return List_Id
;
7866 -- Build all necessary adjust statements for a single component list
7868 ---------------------------------------
7869 -- Process_Component_List_For_Adjust --
7870 ---------------------------------------
7872 function Process_Component_List_For_Adjust
7873 (Comps
: Node_Id
) return List_Id
7875 Stmts
: constant List_Id
:= New_List
;
7877 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7878 -- Process the declaration of a single controlled component
7880 ----------------------------------
7881 -- Process_Component_For_Adjust --
7882 ----------------------------------
7884 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7885 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7886 Typ
: constant Entity_Id
:= Etype
(Id
);
7892 -- [Deep_]Adjust (V.Id);
7896 -- if not Raised then
7898 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7905 Make_Selected_Component
(Loc
,
7906 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7907 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7910 -- Guard against a missing [Deep_]Adjust when the component
7911 -- type was not properly frozen.
7913 if Present
(Adj_Call
) then
7914 if Exceptions_OK
then
7916 Make_Block_Statement
(Loc
,
7917 Handled_Statement_Sequence
=>
7918 Make_Handled_Sequence_Of_Statements
(Loc
,
7919 Statements
=> New_List
(Adj_Call
),
7920 Exception_Handlers
=> New_List
(
7921 Build_Exception_Handler
(Finalizer_Data
))));
7924 Append_To
(Stmts
, Adj_Call
);
7926 end Process_Component_For_Adjust
;
7931 Decl_Id
: Entity_Id
;
7932 Decl_Typ
: Entity_Id
;
7937 -- Start of processing for Process_Component_List_For_Adjust
7940 -- Perform an initial check, determine the number of controlled
7941 -- components in the current list and whether at least one of them
7942 -- is per-object constrained.
7944 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7946 -- The processing in this routine is done in the following order:
7947 -- 1) Regular components
7948 -- 2) Per-object constrained components
7951 if Num_Comps
> 0 then
7953 -- Process all regular components in order of declarations
7955 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7956 while Present
(Decl
) loop
7957 Decl_Id
:= Defining_Identifier
(Decl
);
7958 Decl_Typ
:= Etype
(Decl_Id
);
7960 -- Skip _parent as well as per-object constrained components
7962 if Chars
(Decl_Id
) /= Name_uParent
7963 and then Needs_Finalization
(Decl_Typ
)
7965 if Has_Access_Constraint
(Decl_Id
)
7966 and then No
(Expression
(Decl
))
7970 Process_Component_For_Adjust
(Decl
);
7974 Next_Non_Pragma
(Decl
);
7977 -- Process all per-object constrained components in order of
7981 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7982 while Present
(Decl
) loop
7983 Decl_Id
:= Defining_Identifier
(Decl
);
7984 Decl_Typ
:= Etype
(Decl_Id
);
7988 if Chars
(Decl_Id
) /= Name_uParent
7989 and then Needs_Finalization
(Decl_Typ
)
7990 and then Has_Access_Constraint
(Decl_Id
)
7991 and then No
(Expression
(Decl
))
7993 Process_Component_For_Adjust
(Decl
);
7996 Next_Non_Pragma
(Decl
);
8001 -- Process all variants, if any
8004 if Present
(Variant_Part
(Comps
)) then
8006 Var_Alts
: constant List_Id
:= New_List
;
8010 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
8011 while Present
(Var
) loop
8014 -- when <discrete choices> =>
8015 -- <adjust statements>
8017 Append_To
(Var_Alts
,
8018 Make_Case_Statement_Alternative
(Loc
,
8020 New_Copy_List
(Discrete_Choices
(Var
)),
8022 Process_Component_List_For_Adjust
(
8023 Component_List
(Var
))));
8025 Next_Non_Pragma
(Var
);
8029 -- case V.<discriminant> is
8030 -- when <discrete choices 1> =>
8031 -- <adjust statements 1>
8033 -- when <discrete choices N> =>
8034 -- <adjust statements N>
8038 Make_Case_Statement
(Loc
,
8040 Make_Selected_Component
(Loc
,
8041 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8043 Make_Identifier
(Loc
,
8044 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
8045 Alternatives
=> Var_Alts
);
8049 -- Add the variant case statement to the list of statements
8051 if Present
(Var_Case
) then
8052 Append_To
(Stmts
, Var_Case
);
8055 -- If the component list did not have any controlled components
8056 -- nor variants, return null.
8058 if Is_Empty_List
(Stmts
) then
8059 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
8063 end Process_Component_List_For_Adjust
;
8067 Bod_Stmts
: List_Id
:= No_List
;
8068 Finalizer_Decls
: List_Id
:= No_List
;
8071 -- Start of processing for Build_Adjust_Statements
8074 Finalizer_Decls
:= New_List
;
8075 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
8077 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
8078 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
8083 -- Create an adjust sequence for all record components
8085 if Present
(Component_List
(Rec_Def
)) then
8087 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
8090 -- A derived record type must adjust all inherited components. This
8091 -- action poses the following problem:
8093 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
8098 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
8100 -- Deep_Adjust (Obj._parent);
8105 -- Adjusting the derived type will invoke Adjust of the parent and
8106 -- then that of the derived type. This is undesirable because both
8107 -- routines may modify shared components. Only the Adjust of the
8108 -- derived type should be invoked.
8110 -- To prevent this double adjustment of shared components,
8111 -- Deep_Adjust uses a flag to control the invocation of Adjust:
8113 -- procedure Deep_Adjust
8114 -- (Obj : in out Some_Type;
8115 -- Flag : Boolean := True)
8123 -- When Deep_Adjust is invoked for field _parent, a value of False is
8124 -- provided for the flag:
8126 -- Deep_Adjust (Obj._parent, False);
8128 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8130 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
8135 if Needs_Finalization
(Par_Typ
) then
8139 Make_Selected_Component
(Loc
,
8140 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8142 Make_Identifier
(Loc
, Name_uParent
)),
8148 -- Deep_Adjust (V._parent, False);
8151 -- when Id : others =>
8152 -- if not Raised then
8154 -- Save_Occurrence (E,
8155 -- Get_Current_Excep.all.all);
8159 if Present
(Call
) then
8162 if Exceptions_OK
then
8164 Make_Block_Statement
(Loc
,
8165 Handled_Statement_Sequence
=>
8166 Make_Handled_Sequence_Of_Statements
(Loc
,
8167 Statements
=> New_List
(Adj_Stmt
),
8168 Exception_Handlers
=> New_List
(
8169 Build_Exception_Handler
(Finalizer_Data
))));
8172 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
8178 -- Adjust the object. This action must be performed last after all
8179 -- components have been adjusted.
8181 if Is_Controlled
(Typ
) then
8187 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
8196 -- if not Raised then
8198 -- Save_Occurrence (E,
8199 -- Get_Current_Excep.all.all);
8204 if Present
(Proc
) then
8206 Make_Procedure_Call_Statement
(Loc
,
8207 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8208 Parameter_Associations
=> New_List
(
8209 Make_Identifier
(Loc
, Name_V
)));
8211 if Exceptions_OK
then
8213 Make_Block_Statement
(Loc
,
8214 Handled_Statement_Sequence
=>
8215 Make_Handled_Sequence_Of_Statements
(Loc
,
8216 Statements
=> New_List
(Adj_Stmt
),
8217 Exception_Handlers
=> New_List
(
8218 Build_Exception_Handler
8219 (Finalizer_Data
))));
8222 Append_To
(Bod_Stmts
,
8223 Make_If_Statement
(Loc
,
8224 Condition
=> Make_Identifier
(Loc
, Name_F
),
8225 Then_Statements
=> New_List
(Adj_Stmt
)));
8230 -- At this point either all adjustment statements have been generated
8231 -- or the type is not controlled.
8233 if Is_Empty_List
(Bod_Stmts
) then
8234 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
8240 -- Abort : constant Boolean := Triggered_By_Abort;
8242 -- Abort : constant Boolean := False; -- no abort
8244 -- E : Exception_Occurrence;
8245 -- Raised : Boolean := False;
8248 -- <adjust statements>
8250 -- if Raised and then not Abort then
8251 -- Raise_From_Controlled_Operation (E);
8256 if Exceptions_OK
then
8257 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8262 Make_Block_Statement
(Loc
,
8265 Handled_Statement_Sequence
=>
8266 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8268 end Build_Adjust_Statements
;
8270 -------------------------------
8271 -- Build_Finalize_Statements --
8272 -------------------------------
8274 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
8275 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8276 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
8279 Finalizer_Data
: Finalization_Exception_Data
;
8281 function Process_Component_List_For_Finalize
8282 (Comps
: Node_Id
) return List_Id
;
8283 -- Build all necessary finalization statements for a single component
8284 -- list. The statements may include a jump circuitry if flag Is_Local
8287 -----------------------------------------
8288 -- Process_Component_List_For_Finalize --
8289 -----------------------------------------
8291 function Process_Component_List_For_Finalize
8292 (Comps
: Node_Id
) return List_Id
8294 procedure Process_Component_For_Finalize
8299 Num_Comps
: in out Nat
);
8300 -- Process the declaration of a single controlled component. If
8301 -- flag Is_Local is enabled, create the corresponding label and
8302 -- jump circuitry. Alts is the list of case alternatives, Decls
8303 -- is the top level declaration list where labels are declared
8304 -- and Stmts is the list of finalization actions. Num_Comps
8305 -- denotes the current number of components needing finalization.
8307 ------------------------------------
8308 -- Process_Component_For_Finalize --
8309 ------------------------------------
8311 procedure Process_Component_For_Finalize
8316 Num_Comps
: in out Nat
)
8318 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
8319 Typ
: constant Entity_Id
:= Etype
(Id
);
8326 Label_Id
: Entity_Id
;
8333 Make_Identifier
(Loc
,
8334 Chars
=> New_External_Name
('L', Num_Comps
));
8335 Set_Entity
(Label_Id
,
8336 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
8337 Label
:= Make_Label
(Loc
, Label_Id
);
8340 Make_Implicit_Label_Declaration
(Loc
,
8341 Defining_Identifier
=> Entity
(Label_Id
),
8342 Label_Construct
=> Label
));
8349 Make_Case_Statement_Alternative
(Loc
,
8350 Discrete_Choices
=> New_List
(
8351 Make_Integer_Literal
(Loc
, Num_Comps
)),
8353 Statements
=> New_List
(
8354 Make_Goto_Statement
(Loc
,
8356 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
8361 Append_To
(Stmts
, Label
);
8363 -- Decrease the number of components to be processed.
8364 -- This action yields a new Label_Id in future calls.
8366 Num_Comps
:= Num_Comps
- 1;
8371 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
8373 -- begin -- Exception handlers allowed
8374 -- [Deep_]Finalize (V.Id);
8377 -- if not Raised then
8379 -- Save_Occurrence (E,
8380 -- Get_Current_Excep.all.all);
8387 Make_Selected_Component
(Loc
,
8388 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8389 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
8392 -- Guard against a missing [Deep_]Finalize when the component
8393 -- type was not properly frozen.
8395 if Present
(Fin_Call
) then
8396 if Exceptions_OK
then
8398 Make_Block_Statement
(Loc
,
8399 Handled_Statement_Sequence
=>
8400 Make_Handled_Sequence_Of_Statements
(Loc
,
8401 Statements
=> New_List
(Fin_Call
),
8402 Exception_Handlers
=> New_List
(
8403 Build_Exception_Handler
(Finalizer_Data
))));
8406 Append_To
(Stmts
, Fin_Call
);
8408 end Process_Component_For_Finalize
;
8413 Counter_Id
: Entity_Id
:= Empty
;
8415 Decl_Id
: Entity_Id
;
8416 Decl_Typ
: Entity_Id
;
8419 Jump_Block
: Node_Id
;
8421 Label_Id
: Entity_Id
;
8426 -- Start of processing for Process_Component_List_For_Finalize
8429 -- Perform an initial check, look for controlled and per-object
8430 -- constrained components.
8432 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
8434 -- Create a state counter to service the current component list.
8435 -- This step is performed before the variants are inspected in
8436 -- order to generate the same state counter names as those from
8437 -- Build_Initialize_Statements.
8439 if Num_Comps
> 0 and then Is_Local
then
8440 Counter
:= Counter
+ 1;
8443 Make_Defining_Identifier
(Loc
,
8444 Chars
=> New_External_Name
('C', Counter
));
8447 -- Process the component in the following order:
8449 -- 2) Per-object constrained components
8450 -- 3) Regular components
8452 -- Start with the variant parts
8455 if Present
(Variant_Part
(Comps
)) then
8457 Var_Alts
: constant List_Id
:= New_List
;
8461 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
8462 while Present
(Var
) loop
8465 -- when <discrete choices> =>
8466 -- <finalize statements>
8468 Append_To
(Var_Alts
,
8469 Make_Case_Statement_Alternative
(Loc
,
8471 New_Copy_List
(Discrete_Choices
(Var
)),
8473 Process_Component_List_For_Finalize
(
8474 Component_List
(Var
))));
8476 Next_Non_Pragma
(Var
);
8480 -- case V.<discriminant> is
8481 -- when <discrete choices 1> =>
8482 -- <finalize statements 1>
8484 -- when <discrete choices N> =>
8485 -- <finalize statements N>
8489 Make_Case_Statement
(Loc
,
8491 Make_Selected_Component
(Loc
,
8492 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8494 Make_Identifier
(Loc
,
8495 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
8496 Alternatives
=> Var_Alts
);
8500 -- The current component list does not have a single controlled
8501 -- component, however it may contain variants. Return the case
8502 -- statement for the variants or nothing.
8504 if Num_Comps
= 0 then
8505 if Present
(Var_Case
) then
8506 return New_List
(Var_Case
);
8508 return New_List
(Make_Null_Statement
(Loc
));
8512 -- Prepare all lists
8518 -- Process all per-object constrained components in reverse order
8521 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
8522 while Present
(Decl
) loop
8523 Decl_Id
:= Defining_Identifier
(Decl
);
8524 Decl_Typ
:= Etype
(Decl_Id
);
8528 if Chars
(Decl_Id
) /= Name_uParent
8529 and then Needs_Finalization
(Decl_Typ
)
8530 and then Has_Access_Constraint
(Decl_Id
)
8531 and then No
(Expression
(Decl
))
8533 Process_Component_For_Finalize
8534 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
8537 Prev_Non_Pragma
(Decl
);
8541 -- Process the rest of the components in reverse order
8543 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
8544 while Present
(Decl
) loop
8545 Decl_Id
:= Defining_Identifier
(Decl
);
8546 Decl_Typ
:= Etype
(Decl_Id
);
8550 if Chars
(Decl_Id
) /= Name_uParent
8551 and then Needs_Finalization
(Decl_Typ
)
8553 -- Skip per-object constrained components since they were
8554 -- handled in the above step.
8556 if Has_Access_Constraint
(Decl_Id
)
8557 and then No
(Expression
(Decl
))
8561 Process_Component_For_Finalize
8562 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
8566 Prev_Non_Pragma
(Decl
);
8571 -- LN : label; -- If Is_Local is enabled
8576 -- case CounterX is .
8586 -- <<LN>> -- If Is_Local is enabled
8588 -- [Deep_]Finalize (V.CompY);
8590 -- when Id : others =>
8591 -- if not Raised then
8593 -- Save_Occurrence (E,
8594 -- Get_Current_Excep.all.all);
8598 -- <<L0>> -- If Is_Local is enabled
8603 -- Add the declaration of default jump location L0, its
8604 -- corresponding alternative and its place in the statements.
8606 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
8607 Set_Entity
(Label_Id
,
8608 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
8609 Label
:= Make_Label
(Loc
, Label_Id
);
8611 Append_To
(Decls
, -- declaration
8612 Make_Implicit_Label_Declaration
(Loc
,
8613 Defining_Identifier
=> Entity
(Label_Id
),
8614 Label_Construct
=> Label
));
8616 Append_To
(Alts
, -- alternative
8617 Make_Case_Statement_Alternative
(Loc
,
8618 Discrete_Choices
=> New_List
(
8619 Make_Others_Choice
(Loc
)),
8621 Statements
=> New_List
(
8622 Make_Goto_Statement
(Loc
,
8623 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
8625 Append_To
(Stmts
, Label
); -- statement
8627 -- Create the jump block
8630 Make_Case_Statement
(Loc
,
8631 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
8632 Alternatives
=> Alts
));
8636 Make_Block_Statement
(Loc
,
8637 Declarations
=> Decls
,
8638 Handled_Statement_Sequence
=>
8639 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8641 if Present
(Var_Case
) then
8642 return New_List
(Var_Case
, Jump_Block
);
8644 return New_List
(Jump_Block
);
8646 end Process_Component_List_For_Finalize
;
8650 Bod_Stmts
: List_Id
:= No_List
;
8651 Finalizer_Decls
: List_Id
:= No_List
;
8654 -- Start of processing for Build_Finalize_Statements
8657 Finalizer_Decls
:= New_List
;
8658 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
8660 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
8661 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
8666 -- Create a finalization sequence for all record components
8668 if Present
(Component_List
(Rec_Def
)) then
8670 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
8673 -- A derived record type must finalize all inherited components. This
8674 -- action poses the following problem:
8676 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
8681 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
8683 -- Deep_Finalize (Obj._parent);
8688 -- Finalizing the derived type will invoke Finalize of the parent and
8689 -- then that of the derived type. This is undesirable because both
8690 -- routines may modify shared components. Only the Finalize of the
8691 -- derived type should be invoked.
8693 -- To prevent this double adjustment of shared components,
8694 -- Deep_Finalize uses a flag to control the invocation of Finalize:
8696 -- procedure Deep_Finalize
8697 -- (Obj : in out Some_Type;
8698 -- Flag : Boolean := True)
8706 -- When Deep_Finalize is invoked for field _parent, a value of False
8707 -- is provided for the flag:
8709 -- Deep_Finalize (Obj._parent, False);
8711 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8713 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
8718 if Needs_Finalization
(Par_Typ
) then
8722 Make_Selected_Component
(Loc
,
8723 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8725 Make_Identifier
(Loc
, Name_uParent
)),
8731 -- Deep_Finalize (V._parent, False);
8734 -- when Id : others =>
8735 -- if not Raised then
8737 -- Save_Occurrence (E,
8738 -- Get_Current_Excep.all.all);
8742 if Present
(Call
) then
8745 if Exceptions_OK
then
8747 Make_Block_Statement
(Loc
,
8748 Handled_Statement_Sequence
=>
8749 Make_Handled_Sequence_Of_Statements
(Loc
,
8750 Statements
=> New_List
(Fin_Stmt
),
8751 Exception_Handlers
=> New_List
(
8752 Build_Exception_Handler
8753 (Finalizer_Data
))));
8756 Append_To
(Bod_Stmts
, Fin_Stmt
);
8762 -- Finalize the object. This action must be performed first before
8763 -- all components have been finalized.
8765 if Is_Controlled
(Typ
) and then not Is_Local
then
8771 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8780 -- if not Raised then
8782 -- Save_Occurrence (E,
8783 -- Get_Current_Excep.all.all);
8788 if Present
(Proc
) then
8790 Make_Procedure_Call_Statement
(Loc
,
8791 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8792 Parameter_Associations
=> New_List
(
8793 Make_Identifier
(Loc
, Name_V
)));
8795 if Exceptions_OK
then
8797 Make_Block_Statement
(Loc
,
8798 Handled_Statement_Sequence
=>
8799 Make_Handled_Sequence_Of_Statements
(Loc
,
8800 Statements
=> New_List
(Fin_Stmt
),
8801 Exception_Handlers
=> New_List
(
8802 Build_Exception_Handler
8803 (Finalizer_Data
))));
8806 Prepend_To
(Bod_Stmts
,
8807 Make_If_Statement
(Loc
,
8808 Condition
=> Make_Identifier
(Loc
, Name_F
),
8809 Then_Statements
=> New_List
(Fin_Stmt
)));
8814 -- At this point either all finalization statements have been
8815 -- generated or the type is not controlled.
8817 if No
(Bod_Stmts
) then
8818 return New_List
(Make_Null_Statement
(Loc
));
8822 -- Abort : constant Boolean := Triggered_By_Abort;
8824 -- Abort : constant Boolean := False; -- no abort
8826 -- E : Exception_Occurrence;
8827 -- Raised : Boolean := False;
8830 -- <finalize statements>
8832 -- if Raised and then not Abort then
8833 -- Raise_From_Controlled_Operation (E);
8838 if Exceptions_OK
then
8839 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8844 Make_Block_Statement
(Loc
,
8847 Handled_Statement_Sequence
=>
8848 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8850 end Build_Finalize_Statements
;
8852 -----------------------
8853 -- Parent_Field_Type --
8854 -----------------------
8856 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8860 Field
:= First_Entity
(Typ
);
8861 while Present
(Field
) loop
8862 if Chars
(Field
) = Name_uParent
then
8863 return Etype
(Field
);
8866 Next_Entity
(Field
);
8869 -- A derived tagged type should always have a parent field
8871 raise Program_Error
;
8872 end Parent_Field_Type
;
8874 ---------------------------
8875 -- Preprocess_Components --
8876 ---------------------------
8878 procedure Preprocess_Components
8880 Num_Comps
: out Nat
;
8881 Has_POC
: out Boolean)
8891 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8892 while Present
(Decl
) loop
8893 Id
:= Defining_Identifier
(Decl
);
8896 -- Skip field _parent
8898 if Chars
(Id
) /= Name_uParent
8899 and then Needs_Finalization
(Typ
)
8901 Num_Comps
:= Num_Comps
+ 1;
8903 if Has_Access_Constraint
(Id
)
8904 and then No
(Expression
(Decl
))
8910 Next_Non_Pragma
(Decl
);
8912 end Preprocess_Components
;
8914 -- Start of processing for Make_Deep_Record_Body
8918 when Address_Case
=>
8919 return Make_Finalize_Address_Stmts
(Typ
);
8922 return Build_Adjust_Statements
(Typ
);
8924 when Finalize_Case
=>
8925 return Build_Finalize_Statements
(Typ
);
8927 when Initialize_Case
=>
8929 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8932 if Is_Controlled
(Typ
) then
8934 Make_Procedure_Call_Statement
(Loc
,
8937 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8938 Parameter_Associations
=> New_List
(
8939 Make_Identifier
(Loc
, Name_V
))));
8945 end Make_Deep_Record_Body
;
8947 ----------------------
8948 -- Make_Final_Call --
8949 ----------------------
8951 function Make_Final_Call
8954 Skip_Self
: Boolean := False) return Node_Id
8956 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8958 Fin_Id
: Entity_Id
:= Empty
;
8965 -- Recover the proper type which contains [Deep_]Finalize
8967 if Is_Class_Wide_Type
(Typ
) then
8968 Utyp
:= Root_Type
(Typ
);
8971 elsif Is_Concurrent_Type
(Typ
) then
8972 Utyp
:= Corresponding_Record_Type
(Typ
);
8974 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8976 elsif Is_Private_Type
(Typ
)
8977 and then Present
(Underlying_Type
(Typ
))
8978 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8980 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8982 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8989 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8990 Set_Assignment_OK
(Ref
);
8992 -- Deal with untagged derivation of private views. If the parent type
8993 -- is a protected type, Deep_Finalize is found on the corresponding
8994 -- record of the ancestor.
8996 if Is_Untagged_Derivation
(Typ
) then
8997 if Is_Protected_Type
(Typ
) then
8998 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
9000 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
9002 if Is_Protected_Type
(Utyp
) then
9003 Utyp
:= Corresponding_Record_Type
(Utyp
);
9007 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9008 Set_Assignment_OK
(Ref
);
9011 -- Deal with derived private types which do not inherit primitives from
9012 -- their parents. In this case, [Deep_]Finalize can be found in the full
9013 -- view of the parent type.
9016 and then Is_Tagged_Type
(Utyp
)
9017 and then Is_Derived_Type
(Utyp
)
9018 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
9019 and then Is_Private_Type
(Etype
(Utyp
))
9020 and then Present
(Full_View
(Etype
(Utyp
)))
9022 Utyp
:= Full_View
(Etype
(Utyp
));
9023 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9024 Set_Assignment_OK
(Ref
);
9027 -- When dealing with the completion of a private type, use the base type
9030 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
9031 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
9033 Utyp
:= Base_Type
(Utyp
);
9034 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9035 Set_Assignment_OK
(Ref
);
9038 -- The underlying type may not be present due to a missing full view. In
9039 -- this case freezing did not take place and there is no [Deep_]Finalize
9040 -- primitive to call.
9045 elsif Skip_Self
then
9046 if Has_Controlled_Component
(Utyp
) then
9047 if Is_Tagged_Type
(Utyp
) then
9048 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9050 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
9054 -- Class-wide types, interfaces and types with controlled components
9056 elsif Is_Class_Wide_Type
(Typ
)
9057 or else Is_Interface
(Typ
)
9058 or else Has_Controlled_Component
(Utyp
)
9060 if Is_Tagged_Type
(Utyp
) then
9061 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9063 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
9066 -- Derivations from [Limited_]Controlled
9068 elsif Is_Controlled
(Utyp
) then
9069 if Has_Controlled_Component
(Utyp
) then
9070 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9072 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
9077 elsif Is_Tagged_Type
(Utyp
) then
9078 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9080 -- Protected types: these also require finalization even though they
9081 -- are not marked controlled explicitly.
9083 elsif Is_Protected_Type
(Typ
) then
9084 -- Protected objects do not need to be finalized on restricted
9087 if Restricted_Profile
then
9090 -- ??? Only handle the simple case for now. Will not support a record
9091 -- or array containing protected objects.
9093 elsif Is_Simple_Protected_Type
(Typ
) then
9094 Fin_Id
:= RTE
(RE_Finalize_Protection
);
9096 raise Program_Error
;
9099 raise Program_Error
;
9102 if Present
(Fin_Id
) then
9104 -- When finalizing a class-wide object, do not convert to the root
9105 -- type in order to produce a dispatching call.
9107 if Is_Class_Wide_Type
(Typ
) then
9110 -- Ensure that a finalization routine is at least decorated in order
9111 -- to inspect the object parameter.
9113 elsif Analyzed
(Fin_Id
)
9114 or else Ekind
(Fin_Id
) = E_Procedure
9116 -- In certain cases, such as the creation of Stream_Read, the
9117 -- visible entity of the type is its full view. Since Stream_Read
9118 -- will have to create an object of type Typ, the local object
9119 -- will be finalzed by the scope finalizer generated later on. The
9120 -- object parameter of Deep_Finalize will always use the private
9121 -- view of the type. To avoid such a clash between a private and a
9122 -- full view, perform an unchecked conversion of the object
9123 -- reference to the private view.
9126 Formal_Typ
: constant Entity_Id
:=
9127 Etype
(First_Formal
(Fin_Id
));
9129 if Is_Private_Type
(Formal_Typ
)
9130 and then Present
(Full_View
(Formal_Typ
))
9131 and then Full_View
(Formal_Typ
) = Utyp
9133 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
9137 -- If the object is unanalyzed, set its expected type for use in
9138 -- Convert_View in case an additional conversion is needed.
9141 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
9143 Set_Etype
(Ref
, Typ
);
9146 Ref
:= Convert_View
(Fin_Id
, Ref
);
9153 Skip_Self
=> Skip_Self
);
9157 end Make_Final_Call
;
9159 --------------------------------
9160 -- Make_Finalize_Address_Body --
9161 --------------------------------
9163 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
9164 Is_Task
: constant Boolean :=
9165 Ekind
(Typ
) = E_Record_Type
9166 and then Is_Concurrent_Record_Type
(Typ
)
9167 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
9169 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
9170 Proc_Id
: Entity_Id
;
9174 -- The corresponding records of task types are not controlled by design.
9175 -- For the sake of completeness, create an empty Finalize_Address to be
9176 -- used in task class-wide allocations.
9181 -- Nothing to do if the type is not controlled or it already has a
9182 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
9183 -- come from source. These are usually generated for completeness and
9184 -- do not need the Finalize_Address primitive.
9186 elsif not Needs_Finalization
(Typ
)
9187 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
9189 (Is_Class_Wide_Type
(Typ
)
9190 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
9191 and then not Comes_From_Source
(Root_Type
(Typ
)))
9196 -- Do not generate Finalize_Address routine for CodePeer
9198 if CodePeer_Mode
then
9203 Make_Defining_Identifier
(Loc
,
9204 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
9208 -- procedure <Typ>FD (V : System.Address) is
9210 -- null; -- for tasks
9212 -- declare -- for all other types
9213 -- type Pnn is access all Typ;
9214 -- for Pnn'Storage_Size use 0;
9216 -- [Deep_]Finalize (Pnn (V).all);
9221 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
9223 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
9227 Make_Subprogram_Body
(Loc
,
9229 Make_Procedure_Specification
(Loc
,
9230 Defining_Unit_Name
=> Proc_Id
,
9232 Parameter_Specifications
=> New_List
(
9233 Make_Parameter_Specification
(Loc
,
9234 Defining_Identifier
=>
9235 Make_Defining_Identifier
(Loc
, Name_V
),
9237 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
9239 Declarations
=> No_List
,
9241 Handled_Statement_Sequence
=>
9242 Make_Handled_Sequence_Of_Statements
(Loc
,
9243 Statements
=> Stmts
)));
9245 Set_TSS
(Typ
, Proc_Id
);
9246 end Make_Finalize_Address_Body
;
9248 ---------------------------------
9249 -- Make_Finalize_Address_Stmts --
9250 ---------------------------------
9252 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
9253 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
9256 Desig_Typ
: Entity_Id
;
9257 Fin_Block
: Node_Id
;
9260 Ptr_Typ
: Entity_Id
;
9263 if Is_Array_Type
(Typ
) then
9264 if Is_Constrained
(First_Subtype
(Typ
)) then
9265 Desig_Typ
:= First_Subtype
(Typ
);
9267 Desig_Typ
:= Base_Type
(Typ
);
9270 -- Class-wide types of constrained root types
9272 elsif Is_Class_Wide_Type
(Typ
)
9273 and then Has_Discriminants
(Root_Type
(Typ
))
9275 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
9278 Parent_Typ
: Entity_Id
;
9281 -- Climb the parent type chain looking for a non-constrained type
9283 Parent_Typ
:= Root_Type
(Typ
);
9284 while Parent_Typ
/= Etype
(Parent_Typ
)
9285 and then Has_Discriminants
(Parent_Typ
)
9287 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
9289 Parent_Typ
:= Etype
(Parent_Typ
);
9292 -- Handle views created for tagged types with unknown
9295 if Is_Underlying_Record_View
(Parent_Typ
) then
9296 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
9299 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
9309 -- type Ptr_Typ is access all Typ;
9310 -- for Ptr_Typ'Storage_Size use 0;
9312 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
9315 Make_Full_Type_Declaration
(Loc
,
9316 Defining_Identifier
=> Ptr_Typ
,
9318 Make_Access_To_Object_Definition
(Loc
,
9319 All_Present
=> True,
9320 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
9322 Make_Attribute_Definition_Clause
(Loc
,
9323 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
9324 Chars
=> Name_Storage_Size
,
9325 Expression
=> Make_Integer_Literal
(Loc
, 0)));
9327 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
9329 -- Unconstrained arrays require special processing in order to retrieve
9330 -- the elements. To achieve this, we have to skip the dope vector which
9331 -- lays in front of the elements and then use a thin pointer to perform
9332 -- the address-to-access conversion.
9334 if Is_Array_Type
(Typ
)
9335 and then not Is_Constrained
(First_Subtype
(Typ
))
9338 Dope_Id
: Entity_Id
;
9341 -- Ensure that Ptr_Typ is a thin pointer; generate:
9342 -- for Ptr_Typ'Size use System.Address'Size;
9345 Make_Attribute_Definition_Clause
(Loc
,
9346 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
9349 Make_Integer_Literal
(Loc
, System_Address_Size
)));
9352 -- Dnn : constant Storage_Offset :=
9353 -- Desig_Typ'Descriptor_Size / Storage_Unit;
9355 Dope_Id
:= Make_Temporary
(Loc
, 'D');
9358 Make_Object_Declaration
(Loc
,
9359 Defining_Identifier
=> Dope_Id
,
9360 Constant_Present
=> True,
9361 Object_Definition
=>
9362 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
9364 Make_Op_Divide
(Loc
,
9366 Make_Attribute_Reference
(Loc
,
9367 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
9368 Attribute_Name
=> Name_Descriptor_Size
),
9370 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
9372 -- Shift the address from the start of the dope vector to the
9373 -- start of the elements:
9377 -- Note that this is done through a wrapper routine since RTSfind
9378 -- cannot retrieve operations with string names of the form "+".
9381 Make_Function_Call
(Loc
,
9383 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
9384 Parameter_Associations
=> New_List
(
9386 New_Occurrence_Of
(Dope_Id
, Loc
)));
9393 Make_Explicit_Dereference
(Loc
,
9394 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
9397 if Present
(Fin_Call
) then
9399 Make_Block_Statement
(Loc
,
9400 Declarations
=> Decls
,
9401 Handled_Statement_Sequence
=>
9402 Make_Handled_Sequence_Of_Statements
(Loc
,
9403 Statements
=> New_List
(Fin_Call
)));
9405 -- Otherwise previous errors or a missing full view may prevent the
9406 -- proper freezing of the designated type. If this is the case, there
9407 -- is no [Deep_]Finalize primitive to call.
9410 Fin_Block
:= Make_Null_Statement
(Loc
);
9413 return New_List
(Fin_Block
);
9414 end Make_Finalize_Address_Stmts
;
9416 -------------------------------------
9417 -- Make_Handler_For_Ctrl_Operation --
9418 -------------------------------------
9422 -- when E : others =>
9423 -- Raise_From_Controlled_Operation (E);
9428 -- raise Program_Error [finalize raised exception];
9430 -- depending on whether Raise_From_Controlled_Operation is available
9432 function Make_Handler_For_Ctrl_Operation
9433 (Loc
: Source_Ptr
) return Node_Id
9436 -- Choice parameter (for the first case above)
9438 Raise_Node
: Node_Id
;
9439 -- Procedure call or raise statement
9442 -- Standard run-time: add choice parameter E and pass it to
9443 -- Raise_From_Controlled_Operation so that the original exception
9444 -- name and message can be recorded in the exception message for
9447 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
9448 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
9450 Make_Procedure_Call_Statement
(Loc
,
9453 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
9454 Parameter_Associations
=> New_List
(
9455 New_Occurrence_Of
(E_Occ
, Loc
)));
9457 -- Restricted run-time: exception messages are not supported
9462 Make_Raise_Program_Error
(Loc
,
9463 Reason
=> PE_Finalize_Raised_Exception
);
9467 Make_Implicit_Exception_Handler
(Loc
,
9468 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
9469 Choice_Parameter
=> E_Occ
,
9470 Statements
=> New_List
(Raise_Node
));
9471 end Make_Handler_For_Ctrl_Operation
;
9473 --------------------
9474 -- Make_Init_Call --
9475 --------------------
9477 function Make_Init_Call
9479 Typ
: Entity_Id
) return Node_Id
9481 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
9490 -- Deal with the type and object reference. Depending on the context, an
9491 -- object reference may need several conversions.
9493 if Is_Concurrent_Type
(Typ
) then
9495 Utyp
:= Corresponding_Record_Type
(Typ
);
9496 Ref
:= Convert_Concurrent
(Ref
, Typ
);
9498 elsif Is_Private_Type
(Typ
)
9499 and then Present
(Full_View
(Typ
))
9500 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
9503 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
9504 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
9511 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
9512 Set_Assignment_OK
(Ref
);
9514 -- Deal with untagged derivation of private views
9516 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
9517 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
9518 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9520 -- The following is to prevent problems with UC see 1.156 RH ???
9522 Set_Assignment_OK
(Ref
);
9525 -- If the underlying_type is a subtype, then we are dealing with the
9526 -- completion of a private type. We need to access the base type and
9527 -- generate a conversion to it.
9529 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
9530 pragma Assert
(Is_Private_Type
(Typ
));
9531 Utyp
:= Base_Type
(Utyp
);
9532 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9535 -- The underlying type may not be present due to a missing full view.
9536 -- In this case freezing did not take place and there is no suitable
9537 -- [Deep_]Initialize primitive to call.
9538 -- If Typ is protected then no additional processing is needed either.
9541 or else Is_Protected_Type
(Typ
)
9546 -- Select the appropriate version of initialize
9548 if Has_Controlled_Component
(Utyp
) then
9549 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
9551 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
9552 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
9555 -- If initialization procedure for an array of controlled objects is
9556 -- trivial, do not generate a useless call to it.
9557 -- The initialization procedure may be missing altogether in the case
9558 -- of a derived container whose components have trivial initialization.
9561 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
9563 (not Comes_From_Source
(Proc
)
9564 and then Present
(Alias
(Proc
))
9565 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
9570 -- The object reference may need another conversion depending on the
9571 -- type of the formal and that of the actual.
9573 Ref
:= Convert_View
(Proc
, Ref
);
9576 -- [Deep_]Initialize (Ref);
9579 Make_Procedure_Call_Statement
(Loc
,
9580 Name
=> New_Occurrence_Of
(Proc
, Loc
),
9581 Parameter_Associations
=> New_List
(Ref
));
9584 ------------------------------
9585 -- Make_Local_Deep_Finalize --
9586 ------------------------------
9588 function Make_Local_Deep_Finalize
9590 Nam
: Entity_Id
) return Node_Id
9592 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
9596 Formals
:= New_List
(
9600 Make_Parameter_Specification
(Loc
,
9601 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
9603 Out_Present
=> True,
9604 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
9606 -- F : Boolean := True
9608 Make_Parameter_Specification
(Loc
,
9609 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
9610 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9611 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
9613 -- Add the necessary number of counters to represent the initialization
9614 -- state of an object.
9617 Make_Subprogram_Body
(Loc
,
9619 Make_Procedure_Specification
(Loc
,
9620 Defining_Unit_Name
=> Nam
,
9621 Parameter_Specifications
=> Formals
),
9623 Declarations
=> No_List
,
9625 Handled_Statement_Sequence
=>
9626 Make_Handled_Sequence_Of_Statements
(Loc
,
9627 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
9628 end Make_Local_Deep_Finalize
;
9630 ------------------------------------
9631 -- Make_Set_Finalize_Address_Call --
9632 ------------------------------------
9634 function Make_Set_Finalize_Address_Call
9636 Ptr_Typ
: Entity_Id
) return Node_Id
9638 -- It is possible for Ptr_Typ to be a partial view, if the access type
9639 -- is a full view declared in the private part of a nested package, and
9640 -- the finalization actions take place when completing analysis of the
9641 -- enclosing unit. For this reason use Underlying_Type twice below.
9643 Desig_Typ
: constant Entity_Id
:=
9645 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
9646 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
9647 Fin_Mas
: constant Entity_Id
:=
9648 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
9651 -- Both the finalization master and primitive Finalize_Address must be
9654 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
9657 -- Set_Finalize_Address
9658 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
9661 Make_Procedure_Call_Statement
(Loc
,
9663 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
9664 Parameter_Associations
=> New_List
(
9665 New_Occurrence_Of
(Fin_Mas
, Loc
),
9667 Make_Attribute_Reference
(Loc
,
9668 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
9669 Attribute_Name
=> Name_Unrestricted_Access
)));
9670 end Make_Set_Finalize_Address_Call
;
9672 --------------------------
9673 -- Make_Transient_Block --
9674 --------------------------
9676 function Make_Transient_Block
9679 Par
: Node_Id
) return Node_Id
9681 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
9682 -- Determine whether scoping entity Id manages the secondary stack
9684 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
9685 -- Return True when N appears within a loop and no block is containing N
9687 -----------------------
9688 -- Manages_Sec_Stack --
9689 -----------------------
9691 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
9695 -- An exception handler with a choice parameter utilizes a dummy
9696 -- block to provide a declarative region. Such a block should not
9697 -- be considered because it never manifests in the tree and can
9698 -- never release the secondary stack.
9702 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
9709 return Uses_Sec_Stack
(Id
);
9714 end Manages_Sec_Stack
;
9716 ---------------------------
9717 -- Within_Loop_Statement --
9718 ---------------------------
9720 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
9721 Par
: Node_Id
:= Parent
(N
);
9724 while Nkind
(Par
) not in
9725 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9726 N_Package_Specification | N_Proper_Body
9728 pragma Assert
(Present
(Par
));
9729 Par
:= Parent
(Par
);
9732 return Nkind
(Par
) = N_Loop_Statement
;
9733 end Within_Loop_Statement
;
9737 Decls
: constant List_Id
:= New_List
;
9738 Instrs
: constant List_Id
:= New_List
(Action
);
9739 Trans_Id
: constant Entity_Id
:= Current_Scope
;
9745 -- Start of processing for Make_Transient_Block
9748 -- Even though the transient block is tasked with managing the secondary
9749 -- stack, the block may forgo this functionality depending on how the
9750 -- secondary stack is managed by enclosing scopes.
9752 if Manages_Sec_Stack
(Trans_Id
) then
9754 -- Determine whether an enclosing scope already manages the secondary
9757 Scop
:= Scope
(Trans_Id
);
9758 while Present
(Scop
) loop
9760 -- It should not be possible to reach Standard without hitting one
9761 -- of the other cases first unless Standard was manually pushed.
9763 if Scop
= Standard_Standard
then
9766 -- The transient block is within a function which returns on the
9767 -- secondary stack. Take a conservative approach and assume that
9768 -- the value on the secondary stack is part of the result. Note
9769 -- that it is not possible to detect this dependency without flow
9770 -- analysis which the compiler does not have. Letting the object
9771 -- live longer than the transient block will not leak any memory
9772 -- because the caller will reclaim the total storage used by the
9775 elsif Ekind
(Scop
) = E_Function
9776 and then Sec_Stack_Needed_For_Return
(Scop
)
9778 Set_Uses_Sec_Stack
(Trans_Id
, False);
9781 -- The transient block must manage the secondary stack when the
9782 -- block appears within a loop in order to reclaim the memory at
9785 elsif Ekind
(Scop
) = E_Loop
then
9788 -- Ditto when the block appears without a block that does not
9789 -- manage the secondary stack and is located within a loop.
9791 elsif Ekind
(Scop
) = E_Block
9792 and then not Manages_Sec_Stack
(Scop
)
9793 and then Present
(Block_Node
(Scop
))
9794 and then Within_Loop_Statement
(Block_Node
(Scop
))
9798 -- The transient block does not need to manage the secondary stack
9799 -- when there is an enclosing construct which already does that.
9800 -- This optimization saves on SS_Mark and SS_Release calls but may
9801 -- allow objects to live a little longer than required.
9803 -- The transient block must manage the secondary stack when switch
9804 -- -gnatd.s (strict management) is in effect.
9806 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9807 Set_Uses_Sec_Stack
(Trans_Id
, False);
9810 -- Prevent the search from going too far because transient blocks
9811 -- are bounded by packages and subprogram scopes.
9813 elsif Ekind
(Scop
) in E_Entry
9823 Scop
:= Scope
(Scop
);
9827 -- Create the transient block. Set the parent now since the block itself
9828 -- is not part of the tree. The current scope is the E_Block entity that
9829 -- has been pushed by Establish_Transient_Scope.
9831 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9834 Make_Block_Statement
(Loc
,
9835 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9836 Declarations
=> Decls
,
9837 Handled_Statement_Sequence
=>
9838 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9839 Has_Created_Identifier
=> True);
9840 Set_Parent
(Block
, Par
);
9842 -- Insert actions stuck in the transient scopes as well as all freezing
9843 -- nodes needed by those actions. Do not insert cleanup actions here,
9844 -- they will be transferred to the newly created block.
9846 Insert_Actions_In_Scope_Around
9847 (Action
, Clean
=> False, Manage_SS
=> False);
9849 Insert
:= Prev
(Action
);
9851 if Present
(Insert
) then
9852 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9855 -- Transfer cleanup actions to the newly created block
9858 Cleanup_Actions
: List_Id
9859 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9860 Actions_To_Be_Wrapped
(Cleanup
);
9862 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9863 Cleanup_Actions
:= No_List
;
9866 -- When the transient scope was established, we pushed the entry for the
9867 -- transient scope onto the scope stack, so that the scope was active
9868 -- for the installation of finalizable entities etc. Now we must remove
9869 -- this entry, since we have constructed a proper block.
9874 end Make_Transient_Block
;
9876 ------------------------
9877 -- Node_To_Be_Wrapped --
9878 ------------------------
9880 function Node_To_Be_Wrapped
return Node_Id
is
9882 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9883 end Node_To_Be_Wrapped
;
9885 ----------------------------
9886 -- Store_Actions_In_Scope --
9887 ----------------------------
9889 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9890 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9891 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9894 if Is_Empty_List
(Actions
) then
9897 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9898 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9900 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9905 elsif AK
= Before
then
9906 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9909 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9911 end Store_Actions_In_Scope
;
9913 ----------------------------------
9914 -- Store_After_Actions_In_Scope --
9915 ----------------------------------
9917 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9919 Store_Actions_In_Scope
(After
, L
);
9920 end Store_After_Actions_In_Scope
;
9922 -----------------------------------
9923 -- Store_Before_Actions_In_Scope --
9924 -----------------------------------
9926 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9928 Store_Actions_In_Scope
(Before
, L
);
9929 end Store_Before_Actions_In_Scope
;
9931 -----------------------------------
9932 -- Store_Cleanup_Actions_In_Scope --
9933 -----------------------------------
9935 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9937 Store_Actions_In_Scope
(Cleanup
, L
);
9938 end Store_Cleanup_Actions_In_Scope
;
9944 procedure Unnest_Block
(Decl
: Node_Id
) is
9945 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9947 Local_Body
: Node_Id
;
9948 Local_Call
: Node_Id
;
9949 Local_Proc
: Entity_Id
;
9950 Local_Scop
: Entity_Id
;
9953 Local_Scop
:= Entity
(Identifier
(Decl
));
9954 Ent
:= First_Entity
(Local_Scop
);
9957 Make_Defining_Identifier
(Loc
,
9958 Chars
=> New_Internal_Name
('P'));
9961 Make_Subprogram_Body
(Loc
,
9963 Make_Procedure_Specification
(Loc
,
9964 Defining_Unit_Name
=> Local_Proc
),
9965 Declarations
=> Declarations
(Decl
),
9966 Handled_Statement_Sequence
=>
9967 Handled_Statement_Sequence
(Decl
));
9969 -- Handlers in the block may contain nested subprograms that require
9972 Check_Unnesting_In_Handlers
(Local_Body
);
9974 Rewrite
(Decl
, Local_Body
);
9976 Set_Has_Nested_Subprogram
(Local_Proc
);
9979 Make_Procedure_Call_Statement
(Loc
,
9980 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9982 Insert_After
(Decl
, Local_Call
);
9983 Analyze
(Local_Call
);
9985 -- The new subprogram has the same scope as the original block
9987 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9989 -- And the entity list of the new procedure is that of the block
9991 Set_First_Entity
(Local_Proc
, Ent
);
9993 -- Reset the scopes of all the entities to the new procedure
9995 while Present
(Ent
) loop
9996 Set_Scope
(Ent
, Local_Proc
);
10001 -------------------------
10002 -- Unnest_If_Statement --
10003 -------------------------
10005 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
10007 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
10008 -- A list of statements (that may be a list associated with a then,
10009 -- elsif, or else part of an if-statement) is traversed at the top
10010 -- level to determine whether it contains a subprogram body, and if so,
10011 -- the statements will be replaced with a new procedure body containing
10012 -- the statements followed by a call to the procedure. The individual
10013 -- statements may also be blocks, loops, or other if statements that
10014 -- themselves may require contain nested subprograms needing unnesting.
10016 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
10017 Subp_Found
: Boolean := False;
10020 if Is_Empty_List
(Stmts
) then
10025 Stmt
: Node_Id
:= First
(Stmts
);
10027 while Present
(Stmt
) loop
10028 if Nkind
(Stmt
) = N_Subprogram_Body
then
10029 Subp_Found
:= True;
10037 -- The statements themselves may be blocks, loops, etc. that in turn
10038 -- contain nested subprograms requiring an unnesting transformation.
10039 -- We perform this traversal after looking for subprogram bodies, to
10040 -- avoid considering procedures created for one of those statements
10041 -- (such as a block rewritten as a procedure) as a nested subprogram
10042 -- of the statement list (which could result in an unneeded wrapper
10045 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
10047 -- If there was a top-level subprogram body in the statement list,
10048 -- then perform an unnesting transformation on the list by replacing
10049 -- the statements with a wrapper procedure body containing the
10050 -- original statements followed by a call to that procedure.
10053 Unnest_Statement_List
(Stmts
);
10055 end Check_Stmts_For_Subp_Unnesting
;
10059 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
10060 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
10062 -- Start of processing for Unnest_If_Statement
10065 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
10066 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
10068 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
10070 Elsif_Part
: Node_Id
:=
10071 First
(Elsif_Parts
(If_Stmt
));
10072 Elsif_Stmts
: List_Id
;
10074 while Present
(Elsif_Part
) loop
10075 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
10077 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
10078 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
10085 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
10086 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
10087 end Unnest_If_Statement
;
10093 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
10094 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
10096 Local_Body
: Node_Id
;
10097 Local_Call
: Node_Id
;
10098 Local_Proc
: Entity_Id
;
10099 Local_Scop
: Entity_Id
;
10100 Loop_Copy
: constant Node_Id
:=
10101 Relocate_Node
(Loop_Stmt
);
10103 Local_Scop
:= Entity
(Identifier
(Loop_Stmt
));
10104 Ent
:= First_Entity
(Local_Scop
);
10107 Make_Defining_Identifier
(Loc
,
10108 Chars
=> New_Internal_Name
('P'));
10111 Make_Subprogram_Body
(Loc
,
10113 Make_Procedure_Specification
(Loc
,
10114 Defining_Unit_Name
=> Local_Proc
),
10115 Declarations
=> Empty_List
,
10116 Handled_Statement_Sequence
=>
10117 Make_Handled_Sequence_Of_Statements
(Loc
,
10118 Statements
=> New_List
(Loop_Copy
)));
10120 Set_First_Real_Statement
10121 (Handled_Statement_Sequence
(Local_Body
), Loop_Copy
);
10123 Rewrite
(Loop_Stmt
, Local_Body
);
10124 Analyze
(Loop_Stmt
);
10126 Set_Has_Nested_Subprogram
(Local_Proc
);
10129 Make_Procedure_Call_Statement
(Loc
,
10130 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
10132 Insert_After
(Loop_Stmt
, Local_Call
);
10133 Analyze
(Local_Call
);
10135 -- New procedure has the same scope as the original loop, and the scope
10136 -- of the loop is the new procedure.
10138 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
10139 Set_Scope
(Local_Scop
, Local_Proc
);
10141 -- The entity list of the new procedure is that of the loop
10143 Set_First_Entity
(Local_Proc
, Ent
);
10145 -- Note that the entities associated with the loop don't need to have
10146 -- their Scope fields reset, since they're still associated with the
10147 -- same loop entity that now belongs to the copied loop statement.
10150 ---------------------------
10151 -- Unnest_Statement_List --
10152 ---------------------------
10154 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
10155 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
10156 Local_Body
: Node_Id
;
10157 Local_Call
: Node_Id
;
10158 Local_Proc
: Entity_Id
;
10159 New_Stmts
: constant List_Id
:= Empty_List
;
10163 Make_Defining_Identifier
(Loc
,
10164 Chars
=> New_Internal_Name
('P'));
10167 Make_Subprogram_Body
(Loc
,
10169 Make_Procedure_Specification
(Loc
,
10170 Defining_Unit_Name
=> Local_Proc
),
10171 Declarations
=> Empty_List
,
10172 Handled_Statement_Sequence
=>
10173 Make_Handled_Sequence_Of_Statements
(Loc
,
10174 Statements
=> Stmts
));
10176 Append_To
(New_Stmts
, Local_Body
);
10178 Analyze
(Local_Body
);
10180 Set_Has_Nested_Subprogram
(Local_Proc
);
10183 Make_Procedure_Call_Statement
(Loc
,
10184 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
10186 Append_To
(New_Stmts
, Local_Call
);
10187 Analyze
(Local_Call
);
10189 -- Traverse the statements, and for any that are declarations or
10190 -- subprogram bodies that have entities, set the Scope of those
10191 -- entities to the new procedure's Entity_Id.
10194 Stmt
: Node_Id
:= First
(Stmts
);
10197 while Present
(Stmt
) loop
10198 case Nkind
(Stmt
) is
10200 | N_Renaming_Declaration
10202 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
10204 when N_Subprogram_Body
=>
10206 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
10216 Stmts
:= New_Stmts
;
10217 end Unnest_Statement_List
;
10219 --------------------------------
10220 -- Wrap_Transient_Declaration --
10221 --------------------------------
10223 -- If a transient scope has been established during the processing of the
10224 -- Expression of an Object_Declaration, it is not possible to wrap the
10225 -- declaration into a transient block as usual case, otherwise the object
10226 -- would be itself declared in the wrong scope. Therefore, all entities (if
10227 -- any) defined in the transient block are moved to the proper enclosing
10228 -- scope. Furthermore, if they are controlled variables they are finalized
10229 -- right after the declaration. The finalization list of the transient
10230 -- scope is defined as a renaming of the enclosing one so during their
10231 -- initialization they will be attached to the proper finalization list.
10232 -- For instance, the following declaration :
10234 -- X : Typ := F (G (A), G (B));
10236 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
10237 -- is expanded into :
10239 -- X : Typ := [ complex Expression-Action ];
10240 -- [Deep_]Finalize (_v1);
10241 -- [Deep_]Finalize (_v2);
10243 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
10244 Curr_S
: Entity_Id
;
10245 Encl_S
: Entity_Id
;
10248 Curr_S
:= Current_Scope
;
10249 Encl_S
:= Scope
(Curr_S
);
10251 -- Insert all actions including cleanup generated while analyzing or
10252 -- expanding the transient context back into the tree. Manage the
10253 -- secondary stack when the object declaration appears in a library
10254 -- level package [body].
10256 Insert_Actions_In_Scope_Around
10260 Uses_Sec_Stack
(Curr_S
)
10261 and then Nkind
(N
) = N_Object_Declaration
10262 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
10263 and then Is_Library_Level_Entity
(Encl_S
));
10266 -- Relocate local entities declared within the transient scope to the
10267 -- enclosing scope. This action sets their Is_Public flag accordingly.
10269 Transfer_Entities
(Curr_S
, Encl_S
);
10271 -- Mark the enclosing dynamic scope to ensure that the secondary stack
10272 -- is properly released upon exiting the said scope.
10274 if Uses_Sec_Stack
(Curr_S
) then
10275 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
10277 -- Do not mark a function that returns on the secondary stack as the
10278 -- reclamation is done by the caller.
10280 if Ekind
(Curr_S
) = E_Function
10281 and then Requires_Transient_Scope
(Etype
(Curr_S
))
10285 -- Otherwise mark the enclosing dynamic scope
10288 Set_Uses_Sec_Stack
(Curr_S
);
10289 Check_Restriction
(No_Secondary_Stack
, N
);
10292 end Wrap_Transient_Declaration
;
10294 -------------------------------
10295 -- Wrap_Transient_Expression --
10296 -------------------------------
10298 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
10299 Loc
: constant Source_Ptr
:= Sloc
(N
);
10300 Expr
: Node_Id
:= Relocate_Node
(N
);
10301 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
10302 Typ
: constant Entity_Id
:= Etype
(N
);
10309 -- M : constant Mark_Id := SS_Mark;
10310 -- procedure Finalizer is ... (See Build_Finalizer)
10313 -- Temp := <Expr>; -- general case
10314 -- Temp := (if <Expr> then True else False); -- boolean case
10320 -- A special case is made for Boolean expressions so that the back end
10321 -- knows to generate a conditional branch instruction, if running with
10322 -- -fpreserve-control-flow. This ensures that a control-flow change
10323 -- signaling the decision outcome occurs before the cleanup actions.
10325 if Opt
.Suppress_Control_Flow_Optimizations
10326 and then Is_Boolean_Type
(Typ
)
10329 Make_If_Expression
(Loc
,
10330 Expressions
=> New_List
(
10332 New_Occurrence_Of
(Standard_True
, Loc
),
10333 New_Occurrence_Of
(Standard_False
, Loc
)));
10336 Insert_Actions
(N
, New_List
(
10337 Make_Object_Declaration
(Loc
,
10338 Defining_Identifier
=> Temp
,
10339 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
10341 Make_Transient_Block
(Loc
,
10343 Make_Assignment_Statement
(Loc
,
10344 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10345 Expression
=> Expr
),
10346 Par
=> Parent
(N
))));
10348 if Debug_Generated_Code
then
10349 Set_Debug_Info_Needed
(Temp
);
10352 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10353 Analyze_And_Resolve
(N
, Typ
);
10354 end Wrap_Transient_Expression
;
10356 ------------------------------
10357 -- Wrap_Transient_Statement --
10358 ------------------------------
10360 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
10361 Loc
: constant Source_Ptr
:= Sloc
(N
);
10362 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
10367 -- M : constant Mark_Id := SS_Mark;
10368 -- procedure Finalizer is ... (See Build_Finalizer)
10378 Make_Transient_Block
(Loc
,
10379 Action
=> New_Stmt
,
10380 Par
=> Parent
(N
)));
10382 -- With the scope stack back to normal, we can call analyze on the
10383 -- resulting block. At this point, the transient scope is being
10384 -- treated like a perfectly normal scope, so there is nothing
10385 -- special about it.
10387 -- Note: Wrap_Transient_Statement is called with the node already
10388 -- analyzed (i.e. Analyzed (N) is True). This is important, since
10389 -- otherwise we would get a recursive processing of the node when
10390 -- we do this Analyze call.
10393 end Wrap_Transient_Statement
;