1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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 needed when certain temporary objects are created
80 -- by the compiler. These temporary objects are allocated on the secondary
81 -- stack and/or need finalization, and the transient scope is responsible
82 -- for finalizing the objects and reclaiming the memory of the secondary
83 -- stack at the appropriate time. They are generally objects allocated to
84 -- store the result of a function returning an unconstrained or controlled
85 -- value. Expressions needing to be wrapped in a transient scope may appear
86 -- in three different contexts which lead to different kinds of transient
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 --------------------------------------------------
103 -- Transient Blocks and Finalization Management --
104 --------------------------------------------------
106 procedure Insert_Actions_In_Scope_Around
109 Manage_SS
: Boolean);
110 -- Insert the before-actions kept in the scope stack before N, and the
111 -- after-actions after N, which must be a member of a list. If flag Clean
112 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
113 -- calls to mark and release the secondary stack.
115 function Make_Transient_Block
118 Par
: Node_Id
) return Node_Id
;
119 -- Action is a single statement or object declaration. Par is the proper
120 -- parent of the generated block. Create a transient block whose name is
121 -- the current scope and the only handled statement is Action. If Action
122 -- involves controlled objects or secondary stack usage, the corresponding
123 -- cleanup actions are performed at the end of the block.
125 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
126 -- Shared processing for Store_xxx_Actions_In_Scope
128 -----------------------------
129 -- Finalization Management --
130 -----------------------------
132 -- This part describes how Initialization/Adjustment/Finalization
133 -- procedures are generated and called. Two cases must be considered: types
134 -- that are Controlled (Is_Controlled flag set) and composite types that
135 -- contain controlled components (Has_Controlled_Component flag set). In
136 -- the first case the procedures to call are the user-defined primitive
137 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
138 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
139 -- charge of calling the former procedures on the controlled components.
141 -- For records with Has_Controlled_Component set, a hidden "controller"
142 -- component is inserted. This controller component contains its own
143 -- finalization list on which all controlled components are attached
144 -- creating an indirection on the upper-level Finalization list. This
145 -- technique facilitates the management of objects whose number of
146 -- controlled components changes during execution. This controller
147 -- component is itself controlled and is attached to the upper-level
148 -- finalization chain. Its adjust primitive is in charge of calling adjust
149 -- on the components and adjusting the finalization pointer to match their
150 -- new location (see a-finali.adb).
152 -- It is not possible to use a similar technique for arrays that have
153 -- Has_Controlled_Component set. In this case, deep procedures are
154 -- generated that call initialize/adjust/finalize + attachment or
155 -- detachment on the finalization list for all component.
157 -- Initialize calls: they are generated for declarations or dynamic
158 -- allocations of Controlled objects with no initial value. They are always
159 -- followed by an attachment to the current Finalization Chain. For the
160 -- dynamic allocation case this the chain attached to the scope of the
161 -- access type definition otherwise, this is the chain of the current
164 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
165 -- or dynamic allocations of Controlled objects with an initial value.
166 -- (2) after an assignment. In the first case they are followed by an
167 -- attachment to the final chain, in the second case they are not.
169 -- Finalization Calls: They are generated on (1) scope exit, (2)
170 -- assignments, (3) unchecked deallocations. In case (3) they have to
171 -- be detached from the final chain, in case (2) they must not and in
172 -- case (1) this is not important since we are exiting the scope anyway.
176 -- Type extensions will have a new record controller at each derivation
177 -- level containing controlled components. The record controller for
178 -- the parent/ancestor is attached to the finalization list of the
179 -- extension's record controller (i.e. the parent is like a component
180 -- of the extension).
182 -- For types that are both Is_Controlled and Has_Controlled_Components,
183 -- the record controller and the object itself are handled separately.
184 -- It could seem simpler to attach the object at the end of its record
185 -- controller but this would not tackle view conversions properly.
187 -- A classwide type can always potentially have controlled components
188 -- but the record controller of the corresponding actual type may not
189 -- be known at compile time so the dispatch table contains a special
190 -- field that allows computation of the offset of the record controller
191 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
193 -- Here is a simple example of the expansion of a controlled block :
197 -- Y : Controlled := Init;
203 -- Z : R := (C => X);
213 -- _L : System.FI.Finalizable_Ptr;
215 -- procedure _Clean is
218 -- System.FI.Finalize_List (_L);
226 -- Attach_To_Final_List (_L, Finalizable (X), 1);
227 -- at end: Abort_Undefer;
228 -- Y : Controlled := Init;
230 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
238 -- Deep_Initialize (W, _L, 1);
239 -- at end: Abort_Under;
240 -- Z : R := (C => X);
241 -- Deep_Adjust (Z, _L, 1);
245 -- Deep_Finalize (W, False);
246 -- <save W's final pointers>
248 -- <restore W's final pointers>
249 -- Deep_Adjust (W, _L, 0);
254 type Final_Primitives
is
255 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
256 -- This enumeration type is defined in order to ease sharing code for
257 -- building finalization procedures for composite types.
259 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
260 (Initialize_Case
=> Name_Initialize
,
261 Adjust_Case
=> Name_Adjust
,
262 Finalize_Case
=> Name_Finalize
,
263 Address_Case
=> Name_Finalize_Address
);
264 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
265 (Initialize_Case
=> TSS_Deep_Initialize
,
266 Adjust_Case
=> TSS_Deep_Adjust
,
267 Finalize_Case
=> TSS_Deep_Finalize
,
268 Address_Case
=> TSS_Finalize_Address
);
270 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
271 -- Determine whether access type Typ may have a finalization master
273 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
274 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
275 -- Has_Controlled_Component set and store them using the TSS mechanism.
277 function Build_Cleanup_Statements
279 Additional_Cleanup
: List_Id
) return List_Id
;
280 -- Create the cleanup calls for an asynchronous call block, task master,
281 -- protected subprogram body, task allocation block or task body, or
282 -- additional cleanup actions parked on a transient block. If the context
283 -- does not contain the above constructs, the routine returns an empty
286 procedure Build_Finalizer
288 Clean_Stmts
: List_Id
;
291 Defer_Abort
: Boolean;
292 Fin_Id
: out Entity_Id
);
293 -- N may denote an accept statement, block, entry body, package body,
294 -- package spec, protected body, subprogram body, or a task body. Create
295 -- a procedure which contains finalization calls for all controlled objects
296 -- declared in the declarative or statement region of N. The calls are
297 -- built in reverse order relative to the original declarations. In the
298 -- case of a task body, the routine delays the creation of the finalizer
299 -- until all statements have been moved to the task body procedure.
300 -- Clean_Stmts may contain additional context-dependent code used to abort
301 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
302 -- Mark_Id is the secondary stack used in the current context or Empty if
303 -- missing. Top_Decls is the list on which the declaration of the finalizer
304 -- is attached in the non-package case. Defer_Abort indicates that the
305 -- statements passed in perform actions that require abort to be deferred,
306 -- such as for task termination. Fin_Id is the finalizer declaration
309 procedure Build_Finalizer_Helper
311 Clean_Stmts
: List_Id
;
314 Defer_Abort
: Boolean;
315 Fin_Id
: out Entity_Id
;
316 Finalize_Old_Only
: Boolean);
317 -- An internal routine which does all of the heavy lifting on behalf of
320 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
321 -- N is a construct that contains a handled sequence of statements, Fin_Id
322 -- is the entity of a finalizer. Create an At_End handler that covers the
323 -- statements of N and calls Fin_Id. If the handled statement sequence has
324 -- an exception handler, the statements will be wrapped in a block to avoid
325 -- unwanted interaction with the new At_End handler.
327 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
328 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
329 -- Has_Component_Component set and store them using the TSS mechanism.
331 -------------------------------------------
332 -- Unnesting procedures for CCG and LLVM --
333 -------------------------------------------
335 -- Expansion generates subprograms for controlled types management that
336 -- may appear in declarative lists in package declarations and bodies.
337 -- These subprograms appear within generated blocks that contain local
338 -- declarations and a call to finalization procedures. To ensure that
339 -- such subprograms get activation records when needed, we transform the
340 -- block into a procedure body, followed by a call to it in the same
343 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
344 -- The statement part of a package body that is a compilation unit may
345 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
346 -- Mode such subprograms must be handled as nested inside the (implicit)
347 -- elaboration procedure that executes that statement part. To handle
348 -- properly uplevel references we construct that subprogram explicitly,
349 -- to contain blocks and inner subprograms, the statement part becomes
350 -- a call to this subprogram. This is only done if blocks are present
351 -- in the statement list of the body. (It would be nice to unify this
352 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
353 -- they're doing very similar work, but are structured differently. ???)
355 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
356 -- Similarly, the declarations or statements in library-level packages may
357 -- have created blocks with nested subprograms. Such a block must be
358 -- transformed into a procedure followed by a call to it, so that unnesting
359 -- can handle uplevel references within these nested subprograms (typically
360 -- subprograms that handle finalization actions). This also applies to
361 -- nested packages, including instantiations, in which case it must
362 -- recursively process inner bodies.
364 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
365 -- Similarly, check for blocks with nested subprograms occurring within
366 -- a set of exception handlers associated with a package body N.
368 procedure Unnest_Block
(Decl
: Node_Id
);
369 -- Blocks that contain nested subprograms with up-level references need to
370 -- create activation records for them. We do this by rewriting the block as
371 -- a procedure, followed by a call to it in the same declarative list, to
372 -- replicate the semantics of the original block.
374 -- A common source for such block is a transient block created for a
375 -- construct (declaration, assignment, etc.) that involves controlled
376 -- actions or secondary-stack management, in which case the nested
377 -- subprogram is a finalizer.
379 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
380 -- The separate statement lists associated with an if-statement (then part,
381 -- elsif parts, else part) may require unnesting if they directly contain
382 -- a subprogram body that references up-level objects. Each statement list
383 -- is traversed to locate such subprogram bodies, and if a part's statement
384 -- list contains a body, then the list is replaced with a new procedure
385 -- containing the part's statements followed by a call to the procedure.
386 -- Furthermore, any nested blocks, loops, or if statements will also be
387 -- traversed to determine the need for further unnesting transformations.
389 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
390 -- A list of statements that directly contains a subprogram at its outer
391 -- level, that may reference objects declared in that same statement list,
392 -- is rewritten as a procedure containing the statement list Stmts (which
393 -- includes any such objects as well as the nested subprogram), followed by
394 -- a call to the new procedure, and Stmts becomes the list containing the
395 -- procedure and the call. This ensures that Unnest_Subprogram will later
396 -- properly handle up-level references from the nested subprogram to
397 -- objects declared earlier in statement list, by creating an activation
398 -- record and passing it to the nested subprogram. This procedure also
399 -- resets the Scope of objects declared in the statement list, as well as
400 -- the Scope of the nested subprogram, to refer to the new procedure.
401 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
402 -- only be called when known that the statement list contains a subprogram.
404 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
405 -- Top-level Loops that contain nested subprograms with up-level references
406 -- need to have activation records. We do this by rewriting the loop as a
407 -- procedure containing the loop, followed by a call to the procedure in
408 -- the same library-level declarative list, to replicate the semantics of
409 -- the original loop. Such loops can occur due to aggregate expansions and
412 procedure Check_Visibly_Controlled
413 (Prim
: Final_Primitives
;
415 E
: in out Entity_Id
;
416 Cref
: in out Node_Id
);
417 -- The controlled operation declared for a derived type may not be
418 -- overriding, if the controlled operations of the parent type are hidden,
419 -- for example when the parent is a private type whose full view is
420 -- controlled. For other primitive operations we modify the name of the
421 -- operation to indicate that it is not overriding, but this is not
422 -- possible for Initialize, etc. because they have to be retrievable by
423 -- name. Before generating the proper call to one of these operations we
424 -- check whether Typ is known to be controlled at the point of definition.
425 -- If it is not then we must retrieve the hidden operation of the parent
426 -- and use it instead. This is one case that might be solved more cleanly
427 -- once Overriding pragmas or declarations are in place.
429 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
430 -- Check recursively whether a loop or block contains a subprogram that
431 -- may need an activation record.
433 function Convert_View
436 Ind
: Pos
:= 1) return Node_Id
;
437 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
438 -- argument being passed to it. Ind indicates which formal of procedure
439 -- Proc we are trying to match. This function will, if necessary, generate
440 -- a conversion between the partial and full view of Arg to match the type
441 -- of the formal of Proc, or force a conversion to the class-wide type in
442 -- the case where the operation is abstract.
448 Skip_Self
: Boolean := False) return Node_Id
;
449 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
450 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
451 -- an adjust or finalization call. When flag Skip_Self is set, the related
452 -- action has an effect on the components only (if any).
454 function Make_Deep_Proc
455 (Prim
: Final_Primitives
;
457 Stmts
: List_Id
) return Entity_Id
;
458 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
459 -- Deep_Finalize procedures according to the first parameter. These
460 -- procedures operate on the type Typ. The Stmts parameter gives the
461 -- body of the procedure.
463 function Make_Deep_Array_Body
464 (Prim
: Final_Primitives
;
465 Typ
: Entity_Id
) return List_Id
;
466 -- This function generates the list of statements for implementing
467 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
468 -- the first parameter, these procedures operate on the array type Typ.
470 function Make_Deep_Record_Body
471 (Prim
: Final_Primitives
;
473 Is_Local
: Boolean := False) return List_Id
;
474 -- This function generates the list of statements for implementing
475 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
476 -- the first parameter, these procedures operate on the record type Typ.
477 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
478 -- whether the inner logic should be dictated by state counters.
480 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
481 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
482 -- Make_Deep_Record_Body. Generate the following statements:
485 -- type Acc_Typ is access all Typ;
486 -- for Acc_Typ'Storage_Size use 0;
488 -- [Deep_]Finalize (Acc_Typ (V).all);
491 --------------------------------
492 -- Allows_Finalization_Master --
493 --------------------------------
495 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
496 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
497 -- Determine whether entity E is inside a wrapper package created for
498 -- an instance of Ada.Unchecked_Deallocation.
500 ------------------------------
501 -- In_Deallocation_Instance --
502 ------------------------------
504 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
505 Pkg
: constant Entity_Id
:= Scope
(E
);
506 Par
: Node_Id
:= Empty
;
509 if Ekind
(Pkg
) = E_Package
510 and then Present
(Related_Instance
(Pkg
))
511 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
513 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
517 and then Chars
(Par
) = Name_Unchecked_Deallocation
518 and then Chars
(Scope
(Par
)) = Name_Ada
519 and then Scope
(Scope
(Par
)) = Standard_Standard
;
523 end In_Deallocation_Instance
;
527 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
528 Ptr_Typ
: constant Entity_Id
:=
529 Root_Type_Of_Full_View
(Base_Type
(Typ
));
531 -- Start of processing for Allows_Finalization_Master
534 -- Certain run-time configurations and targets do not provide support
535 -- for controlled types and therefore do not need masters.
537 if Restriction_Active
(No_Finalization
) then
540 -- Do not consider C and C++ types since it is assumed that the non-Ada
541 -- side will handle their cleanup.
543 elsif Convention
(Desig_Typ
) = Convention_C
544 or else Convention
(Desig_Typ
) = Convention_CPP
548 -- Do not consider an access type that returns on the secondary stack
550 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
551 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
555 -- Do not consider an access type that can never allocate an object
557 elsif No_Pool_Assigned
(Ptr_Typ
) then
560 -- Do not consider an access type coming from an Unchecked_Deallocation
561 -- instance. Even though the designated type may be controlled, the
562 -- access type will never participate in any allocations.
564 elsif In_Deallocation_Instance
(Ptr_Typ
) then
567 -- Do not consider a non-library access type when No_Nested_Finalization
568 -- is in effect since finalization masters are controlled objects and if
569 -- created will violate the restriction.
571 elsif Restriction_Active
(No_Nested_Finalization
)
572 and then not Is_Library_Level_Entity
(Ptr_Typ
)
576 -- Do not consider an access type subject to pragma No_Heap_Finalization
577 -- because objects allocated through such a type are not to be finalized
578 -- when the access type goes out of scope.
580 elsif No_Heap_Finalization
(Ptr_Typ
) then
583 -- Do not create finalization masters in GNATprove mode because this
584 -- causes unwanted extra expansion. A compilation in this mode must
585 -- keep the tree as close as possible to the original sources.
587 elsif GNATprove_Mode
then
590 -- Otherwise the access type may use a finalization master
595 end Allows_Finalization_Master
;
597 ----------------------------
598 -- Build_Anonymous_Master --
599 ----------------------------
601 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
602 function Create_Anonymous_Master
603 (Desig_Typ
: Entity_Id
;
605 Unit_Decl
: Node_Id
) return Entity_Id
;
606 -- Create a new anonymous master for access type Ptr_Typ with designated
607 -- type Desig_Typ. The declaration of the master and its initialization
608 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
609 -- the entity of Unit_Decl.
611 function Current_Anonymous_Master
612 (Desig_Typ
: Entity_Id
;
613 Unit_Id
: Entity_Id
) return Entity_Id
;
614 -- Find an anonymous master declared within unit Unit_Id which services
615 -- designated type Desig_Typ. If there is no such master, return Empty.
617 -----------------------------
618 -- Create_Anonymous_Master --
619 -----------------------------
621 function Create_Anonymous_Master
622 (Desig_Typ
: Entity_Id
;
624 Unit_Decl
: Node_Id
) return Entity_Id
626 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
637 -- <FM_Id> : Finalization_Master;
639 FM_Id
:= Make_Temporary
(Loc
, 'A');
642 Make_Object_Declaration
(Loc
,
643 Defining_Identifier
=> FM_Id
,
645 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
649 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
652 Make_Procedure_Call_Statement
(Loc
,
654 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
655 Parameter_Associations
=> New_List
(
656 New_Occurrence_Of
(FM_Id
, Loc
),
657 Make_Attribute_Reference
(Loc
,
659 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
660 Attribute_Name
=> Name_Unrestricted_Access
)));
662 -- Find the declarative list of the unit
664 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
665 Unit_Spec
:= Specification
(Unit_Decl
);
666 Decls
:= Visible_Declarations
(Unit_Spec
);
670 Set_Visible_Declarations
(Unit_Spec
, Decls
);
673 -- Package body or subprogram case
675 -- ??? A subprogram spec or body that acts as a compilation unit may
676 -- contain a formal parameter of an anonymous access-to-controlled
677 -- type initialized by an allocator.
679 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
681 -- There is no suitable place to create the master as the subprogram
682 -- is not in a declarative list.
685 Decls
:= Declarations
(Unit_Decl
);
689 Set_Declarations
(Unit_Decl
, Decls
);
693 Prepend_To
(Decls
, FM_Init
);
694 Prepend_To
(Decls
, FM_Decl
);
696 -- Use the scope of the unit when analyzing the declaration of the
697 -- master and its initialization actions.
699 Push_Scope
(Unit_Id
);
704 -- Mark the master as servicing this specific designated type
706 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
708 -- Include the anonymous master in the list of existing masters which
709 -- appear in this unit. This effectively creates a mapping between a
710 -- master and a designated type which in turn allows for the reuse of
711 -- masters on a per-unit basis.
713 All_FMs
:= Anonymous_Masters
(Unit_Id
);
716 All_FMs
:= New_Elmt_List
;
717 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
720 Prepend_Elmt
(FM_Id
, All_FMs
);
723 end Create_Anonymous_Master
;
725 ------------------------------
726 -- Current_Anonymous_Master --
727 ------------------------------
729 function Current_Anonymous_Master
730 (Desig_Typ
: Entity_Id
;
731 Unit_Id
: Entity_Id
) return Entity_Id
733 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
738 -- Inspect the list of anonymous masters declared within the unit
739 -- looking for an existing master which services the same designated
742 if Present
(All_FMs
) then
743 FM_Elmt
:= First_Elmt
(All_FMs
);
744 while Present
(FM_Elmt
) loop
745 FM_Id
:= Node
(FM_Elmt
);
747 -- The currect master services the same designated type. As a
748 -- result the master can be reused and associated with another
749 -- anonymous access-to-controlled type.
751 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
760 end Current_Anonymous_Master
;
764 Desig_Typ
: Entity_Id
;
766 Priv_View
: Entity_Id
;
770 -- Start of processing for Build_Anonymous_Master
773 -- Nothing to do if the circumstances do not allow for a finalization
776 if not Allows_Finalization_Master
(Ptr_Typ
) then
780 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
781 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
783 -- The compilation unit is a package instantiation. In this case the
784 -- anonymous master is associated with the package spec as both the
785 -- spec and body appear at the same level.
787 if Nkind
(Unit_Decl
) = N_Package_Body
788 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
790 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
791 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
794 -- Use the initial declaration of the designated type when it denotes
795 -- the full view of an incomplete or private type. This ensures that
796 -- types with one and two views are treated the same.
798 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
799 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
801 if Present
(Priv_View
) then
802 Desig_Typ
:= Priv_View
;
805 -- Determine whether the current semantic unit already has an anonymous
806 -- master which services the designated type.
808 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
810 -- If this is not the case, create a new master
813 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
816 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
817 end Build_Anonymous_Master
;
819 ----------------------------
820 -- Build_Array_Deep_Procs --
821 ----------------------------
823 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
827 (Prim
=> Initialize_Case
,
829 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
831 if not Is_Limited_View
(Typ
) then
834 (Prim
=> Adjust_Case
,
836 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
839 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
840 -- suppressed since these routine will not be used.
842 if not Restriction_Active
(No_Finalization
) then
845 (Prim
=> Finalize_Case
,
847 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
849 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
851 if not CodePeer_Mode
then
854 (Prim
=> Address_Case
,
856 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
859 end Build_Array_Deep_Procs
;
861 ------------------------------
862 -- Build_Cleanup_Statements --
863 ------------------------------
865 function Build_Cleanup_Statements
867 Additional_Cleanup
: List_Id
) return List_Id
869 Is_Asynchronous_Call
: constant Boolean :=
870 Nkind
(N
) = N_Block_Statement
and then Is_Asynchronous_Call_Block
(N
);
871 Is_Master
: constant Boolean :=
872 Nkind
(N
) /= N_Entry_Body
and then Is_Task_Master
(N
);
873 Is_Protected_Subp_Body
: constant Boolean :=
874 Nkind
(N
) = N_Subprogram_Body
875 and then Is_Protected_Subprogram_Body
(N
);
876 Is_Task_Allocation
: constant Boolean :=
877 Nkind
(N
) = N_Block_Statement
and then Is_Task_Allocation_Block
(N
);
878 Is_Task_Body
: constant Boolean :=
879 Nkind
(Original_Node
(N
)) = N_Task_Body
;
881 Loc
: constant Source_Ptr
:= Sloc
(N
);
882 Stmts
: constant List_Id
:= New_List
;
886 if Restricted_Profile
then
888 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
890 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
894 if Restriction_Active
(No_Task_Hierarchy
) = False then
895 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
898 -- Add statements to unlock the protected object parameter and to
899 -- undefer abort. If the context is a protected procedure and the object
900 -- has entries, call the entry service routine.
902 -- NOTE: The generated code references _object, a parameter to the
905 elsif Is_Protected_Subp_Body
then
907 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
908 Conc_Typ
: Entity_Id
:= Empty
;
910 Param_Typ
: Entity_Id
;
913 -- Find the _object parameter representing the protected object
915 Param
:= First
(Parameter_Specifications
(Spec
));
917 Param_Typ
:= Etype
(Parameter_Type
(Param
));
919 if Ekind
(Param_Typ
) = E_Record_Type
then
920 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
923 exit when No
(Param
) or else Present
(Conc_Typ
);
927 pragma Assert
(Present
(Param
));
928 pragma Assert
(Present
(Conc_Typ
));
930 -- Historical note: In earlier versions of GNAT, there was code
931 -- at this point to generate stuff to service entry queues. It is
932 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
934 Build_Protected_Subprogram_Call_Cleanup
935 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
938 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
939 -- tasks. Other unactivated tasks are completed by Complete_Task or
942 -- NOTE: The generated code references _chain, a local object
944 elsif Is_Task_Allocation
then
947 -- Expunge_Unactivated_Tasks (_chain);
949 -- where _chain is the list of tasks created by the allocator but not
950 -- yet activated. This list will be empty unless the block completes
954 Make_Procedure_Call_Statement
(Loc
,
957 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
958 Parameter_Associations
=> New_List
(
959 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
961 -- Attempt to cancel an asynchronous entry call whenever the block which
962 -- contains the abortable part is exited.
964 -- NOTE: The generated code references Cnn, a local object
966 elsif Is_Asynchronous_Call
then
968 Cancel_Param
: constant Entity_Id
:=
969 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
972 -- If it is of type Communication_Block, this must be a protected
973 -- entry call. Generate:
975 -- if Enqueued (Cancel_Param) then
976 -- Cancel_Protected_Entry_Call (Cancel_Param);
979 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
981 Make_If_Statement
(Loc
,
983 Make_Function_Call
(Loc
,
985 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
986 Parameter_Associations
=> New_List
(
987 New_Occurrence_Of
(Cancel_Param
, Loc
))),
989 Then_Statements
=> New_List
(
990 Make_Procedure_Call_Statement
(Loc
,
993 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
994 Parameter_Associations
=> New_List
(
995 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
997 -- Asynchronous delay, generate:
998 -- Cancel_Async_Delay (Cancel_Param);
1000 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
1002 Make_Procedure_Call_Statement
(Loc
,
1004 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
1005 Parameter_Associations
=> New_List
(
1006 Make_Attribute_Reference
(Loc
,
1008 New_Occurrence_Of
(Cancel_Param
, Loc
),
1009 Attribute_Name
=> Name_Unchecked_Access
))));
1011 -- Task entry call, generate:
1012 -- Cancel_Task_Entry_Call (Cancel_Param);
1016 Make_Procedure_Call_Statement
(Loc
,
1018 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
1019 Parameter_Associations
=> New_List
(
1020 New_Occurrence_Of
(Cancel_Param
, Loc
))));
1025 Append_List_To
(Stmts
, Additional_Cleanup
);
1027 end Build_Cleanup_Statements
;
1029 -----------------------------
1030 -- Build_Controlling_Procs --
1031 -----------------------------
1033 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
1035 if Is_Array_Type
(Typ
) then
1036 Build_Array_Deep_Procs
(Typ
);
1037 else pragma Assert
(Is_Record_Type
(Typ
));
1038 Build_Record_Deep_Procs
(Typ
);
1040 end Build_Controlling_Procs
;
1042 -----------------------------
1043 -- Build_Exception_Handler --
1044 -----------------------------
1046 function Build_Exception_Handler
1047 (Data
: Finalization_Exception_Data
;
1048 For_Library
: Boolean := False) return Node_Id
1051 Proc_To_Call
: Entity_Id
;
1056 pragma Assert
(Present
(Data
.Raised_Id
));
1058 if Exception_Extra_Info
1059 or else (For_Library
and not Restricted_Profile
)
1061 if Exception_Extra_Info
then
1065 -- Get_Current_Excep.all
1068 Make_Function_Call
(Data
.Loc
,
1070 Make_Explicit_Dereference
(Data
.Loc
,
1073 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1080 Except
:= Make_Null
(Data
.Loc
);
1083 if For_Library
and then not Restricted_Profile
then
1084 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1085 Actuals
:= New_List
(Except
);
1088 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1090 -- The dereference occurs only when Exception_Extra_Info is true,
1091 -- and therefore Except is not null.
1095 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1096 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1102 -- if not Raised_Id then
1103 -- Raised_Id := True;
1105 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1107 -- Save_Library_Occurrence (Get_Current_Excep.all);
1112 Make_If_Statement
(Data
.Loc
,
1114 Make_Op_Not
(Data
.Loc
,
1115 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1117 Then_Statements
=> New_List
(
1118 Make_Assignment_Statement
(Data
.Loc
,
1119 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1120 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1122 Make_Procedure_Call_Statement
(Data
.Loc
,
1124 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1125 Parameter_Associations
=> Actuals
))));
1130 -- Raised_Id := True;
1133 Make_Assignment_Statement
(Data
.Loc
,
1134 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1135 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1143 Make_Exception_Handler
(Data
.Loc
,
1144 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1145 Statements
=> Stmts
);
1146 end Build_Exception_Handler
;
1148 -------------------------------
1149 -- Build_Finalization_Master --
1150 -------------------------------
1152 procedure Build_Finalization_Master
1154 For_Lib_Level
: Boolean := False;
1155 For_Private
: Boolean := False;
1156 Context_Scope
: Entity_Id
:= Empty
;
1157 Insertion_Node
: Node_Id
:= Empty
)
1159 procedure Add_Pending_Access_Type
1161 Ptr_Typ
: Entity_Id
);
1162 -- Add access type Ptr_Typ to the pending access type list for type Typ
1164 -----------------------------
1165 -- Add_Pending_Access_Type --
1166 -----------------------------
1168 procedure Add_Pending_Access_Type
1170 Ptr_Typ
: Entity_Id
)
1175 if Present
(Pending_Access_Types
(Typ
)) then
1176 List
:= Pending_Access_Types
(Typ
);
1178 List
:= New_Elmt_List
;
1179 Set_Pending_Access_Types
(Typ
, List
);
1182 Prepend_Elmt
(Ptr_Typ
, List
);
1183 end Add_Pending_Access_Type
;
1187 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1189 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1190 -- A finalization master created for a named access type is associated
1191 -- with the full view (if applicable) as a consequence of freezing. The
1192 -- full view criteria does not apply to anonymous access types because
1193 -- those cannot have a private and a full view.
1195 -- Start of processing for Build_Finalization_Master
1198 -- Nothing to do if the circumstances do not allow for a finalization
1201 if not Allows_Finalization_Master
(Typ
) then
1204 -- Various machinery such as freezing may have already created a
1205 -- finalization master.
1207 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1212 Actions
: constant List_Id
:= New_List
;
1213 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1214 Fin_Mas_Id
: Entity_Id
;
1215 Pool_Id
: Entity_Id
;
1218 -- Source access types use fixed master names since the master is
1219 -- inserted in the same source unit only once. The only exception to
1220 -- this are instances using the same access type as generic actual.
1222 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1224 Make_Defining_Identifier
(Loc
,
1225 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1227 -- Internally generated access types use temporaries as their names
1228 -- due to possible collision with identical names coming from other
1232 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1235 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1238 -- <Ptr_Typ>FM : aliased Finalization_Master;
1241 Make_Object_Declaration
(Loc
,
1242 Defining_Identifier
=> Fin_Mas_Id
,
1243 Aliased_Present
=> True,
1244 Object_Definition
=>
1245 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1247 if Debug_Generated_Code
then
1248 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1251 -- Set the associated pool and primitive Finalize_Address of the new
1252 -- finalization master.
1254 -- The access type has a user-defined storage pool, use it
1256 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1257 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1259 -- Otherwise the default choice is the global storage pool
1262 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1263 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1267 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1270 Make_Procedure_Call_Statement
(Loc
,
1272 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1273 Parameter_Associations
=> New_List
(
1274 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1275 Make_Attribute_Reference
(Loc
,
1276 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1277 Attribute_Name
=> Name_Unrestricted_Access
))));
1279 -- Finalize_Address is not generated in CodePeer mode because the
1280 -- body contains address arithmetic. Skip this step.
1282 if CodePeer_Mode
then
1285 -- Associate the Finalize_Address primitive of the designated type
1286 -- with the finalization master of the access type. The designated
1287 -- type must be forzen as Finalize_Address is generated when the
1288 -- freeze node is expanded.
1290 elsif Is_Frozen
(Desig_Typ
)
1291 and then Present
(Finalize_Address
(Desig_Typ
))
1293 -- The finalization master of an anonymous access type may need
1294 -- to be inserted in a specific place in the tree. For instance:
1298 -- <finalization master of "access Comp_Typ">
1300 -- type Rec_Typ is record
1301 -- Comp : access Comp_Typ;
1304 -- <freeze node for Comp_Typ>
1305 -- <freeze node for Rec_Typ>
1307 -- Due to this oddity, the anonymous access type is stored for
1308 -- later processing (see below).
1310 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1313 -- Set_Finalize_Address
1314 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1317 Make_Set_Finalize_Address_Call
1319 Ptr_Typ
=> Ptr_Typ
));
1321 -- Otherwise the designated type is either anonymous access or a
1322 -- Taft-amendment type and has not been frozen. Store the access
1323 -- type for later processing (see Freeze_Type).
1326 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1329 -- A finalization master created for an access designating a type
1330 -- with private components is inserted before a context-dependent
1335 -- At this point both the scope of the context and the insertion
1336 -- mode must be known.
1338 pragma Assert
(Present
(Context_Scope
));
1339 pragma Assert
(Present
(Insertion_Node
));
1341 Push_Scope
(Context_Scope
);
1343 -- Treat use clauses as declarations and insert directly in front
1346 if Nkind
(Insertion_Node
) in
1347 N_Use_Package_Clause | N_Use_Type_Clause
1349 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1351 Insert_Actions
(Insertion_Node
, Actions
);
1356 -- The finalization master belongs to an access result type related
1357 -- to a build-in-place function call used to initialize a library
1358 -- level object. The master must be inserted in front of the access
1359 -- result type declaration denoted by Insertion_Node.
1361 elsif For_Lib_Level
then
1362 pragma Assert
(Present
(Insertion_Node
));
1363 Insert_Actions
(Insertion_Node
, Actions
);
1365 -- Otherwise the finalization master and its initialization become a
1366 -- part of the freeze node.
1369 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1372 Analyze_List
(Actions
);
1374 -- When the type the finalization master is being generated for was
1375 -- created to store a 'Old object, then mark it as such so its
1376 -- finalization can be delayed until after postconditions have been
1379 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1380 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1383 end Build_Finalization_Master
;
1385 ----------------------------
1386 -- Build_Finalizer_Helper --
1387 ----------------------------
1389 procedure Build_Finalizer_Helper
1391 Clean_Stmts
: List_Id
;
1392 Mark_Id
: Entity_Id
;
1393 Top_Decls
: List_Id
;
1394 Defer_Abort
: Boolean;
1395 Fin_Id
: out Entity_Id
;
1396 Finalize_Old_Only
: Boolean)
1398 Acts_As_Clean
: constant Boolean :=
1401 (Present
(Clean_Stmts
)
1402 and then Is_Non_Empty_List
(Clean_Stmts
));
1404 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1405 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1406 For_Package
: constant Boolean :=
1407 For_Package_Body
or else For_Package_Spec
;
1408 Loc
: constant Source_Ptr
:= Sloc
(N
);
1410 -- NOTE: Local variable declarations are conservative and do not create
1411 -- structures right from the start. Entities and lists are created once
1412 -- it has been established that N has at least one controlled object.
1414 Components_Built
: Boolean := False;
1415 -- A flag used to avoid double initialization of entities and lists. If
1416 -- the flag is set then the following variables have been initialized:
1422 Counter_Id
: Entity_Id
:= Empty
;
1423 Counter_Val
: Nat
:= 0;
1424 -- Name and value of the state counter
1426 Decls
: List_Id
:= No_List
;
1427 -- Declarative region of N (if available). If N is a package declaration
1428 -- Decls denotes the visible declarations.
1430 Finalizer_Data
: Finalization_Exception_Data
;
1431 -- Data for the exception
1433 Finalizer_Decls
: List_Id
:= No_List
;
1434 -- Local variable declarations. This list holds the label declarations
1435 -- of all jump block alternatives as well as the declaration of the
1436 -- local exception occurrence and the raised flag:
1437 -- E : Exception_Occurrence;
1438 -- Raised : Boolean := False;
1439 -- L<counter value> : label;
1441 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1442 -- Insertion point for the finalizer body. Depending on the context
1443 -- (Nkind of N) and the individual grouping of controlled objects, this
1444 -- node may denote a package declaration or body, package instantiation,
1445 -- block statement or a counter update statement.
1447 Finalizer_Stmts
: List_Id
:= No_List
;
1448 -- The statement list of the finalizer body. It contains the following:
1450 -- Abort_Defer; -- Added if abort is allowed
1451 -- <call to Prev_At_End> -- Added if exists
1452 -- <cleanup statements> -- Added if Acts_As_Clean
1453 -- <jump block> -- Added if Has_Ctrl_Objs
1454 -- <finalization statements> -- Added if Has_Ctrl_Objs
1455 -- <stack release> -- Added if Mark_Id exists
1456 -- Abort_Undefer; -- Added if abort is allowed
1458 Has_Ctrl_Objs
: Boolean := False;
1459 -- A general flag which denotes whether N has at least one controlled
1462 Has_Tagged_Types
: Boolean := False;
1463 -- A general flag which indicates whether N has at least one library-
1464 -- level tagged type declaration.
1466 HSS
: Node_Id
:= Empty
;
1467 -- The sequence of statements of N (if available)
1469 Jump_Alts
: List_Id
:= No_List
;
1470 -- Jump block alternatives. Depending on the value of the state counter,
1471 -- the control flow jumps to a sequence of finalization statements. This
1472 -- list contains the following:
1474 -- when <counter value> =>
1475 -- goto L<counter value>;
1477 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1478 -- Specific point in the finalizer statements where the jump block is
1481 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1482 -- The last controlled construct encountered when processing the top
1483 -- level lists of N. This can be a nested package, an instantiation or
1484 -- an object declaration.
1486 Prev_At_End
: Entity_Id
:= Empty
;
1487 -- The previous at end procedure of the handled statements block of N
1489 Priv_Decls
: List_Id
:= No_List
;
1490 -- The private declarations of N if N is a package declaration
1492 Spec_Id
: Entity_Id
:= Empty
;
1493 Spec_Decls
: List_Id
:= Top_Decls
;
1494 Stmts
: List_Id
:= No_List
;
1496 Tagged_Type_Stmts
: List_Id
:= No_List
;
1497 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1498 -- tagged types found in N.
1500 -----------------------
1501 -- Local subprograms --
1502 -----------------------
1504 procedure Build_Components
;
1505 -- Create all entites and initialize all lists used in the creation of
1508 procedure Create_Finalizer
;
1509 -- Create the spec and body of the finalizer and insert them in the
1510 -- proper place in the tree depending on the context.
1512 function New_Finalizer_Name
1513 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1514 -- Create a fully qualified name of a package spec or body finalizer.
1515 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1517 procedure Process_Declarations
1519 Preprocess
: Boolean := False;
1520 Top_Level
: Boolean := False);
1521 -- Inspect a list of declarations or statements which may contain
1522 -- objects that need finalization. When flag Preprocess is set, the
1523 -- routine will simply count the total number of controlled objects in
1524 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1525 -- when Preprocess is set and if True, the processing is performed for
1526 -- objects in nested package declarations or instances.
1528 procedure Process_Object_Declaration
1530 Has_No_Init
: Boolean := False;
1531 Is_Protected
: Boolean := False);
1532 -- Generate all the machinery associated with the finalization of a
1533 -- single object. Flag Has_No_Init is used to denote certain contexts
1534 -- where Decl does not have initialization call(s). Flag Is_Protected
1535 -- is set when Decl denotes a simple protected object.
1537 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1538 -- Generate all the code necessary to unregister the external tag of a
1541 ----------------------
1542 -- Build_Components --
1543 ----------------------
1545 procedure Build_Components
is
1546 Counter_Decl
: Node_Id
;
1547 Counter_Typ
: Entity_Id
;
1548 Counter_Typ_Decl
: Node_Id
;
1551 pragma Assert
(Present
(Decls
));
1553 -- This routine might be invoked several times when dealing with
1554 -- constructs that have two lists (either two declarative regions
1555 -- or declarations and statements). Avoid double initialization.
1557 if Components_Built
then
1561 Components_Built
:= True;
1563 if Has_Ctrl_Objs
then
1565 -- Create entities for the counter, its type, the local exception
1566 -- and the raised flag.
1568 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1569 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1571 Finalizer_Decls
:= New_List
;
1573 Build_Object_Declarations
1574 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1576 -- Since the total number of controlled objects is always known,
1577 -- build a subtype of Natural with precise bounds. This allows
1578 -- the backend to optimize the case statement. Generate:
1580 -- subtype Tnn is Natural range 0 .. Counter_Val;
1583 Make_Subtype_Declaration
(Loc
,
1584 Defining_Identifier
=> Counter_Typ
,
1585 Subtype_Indication
=>
1586 Make_Subtype_Indication
(Loc
,
1587 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1589 Make_Range_Constraint
(Loc
,
1593 Make_Integer_Literal
(Loc
, Uint_0
),
1595 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1597 -- Generate the declaration of the counter itself:
1599 -- Counter : Integer := 0;
1602 Make_Object_Declaration
(Loc
,
1603 Defining_Identifier
=> Counter_Id
,
1604 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1605 Expression
=> Make_Integer_Literal
(Loc
, 0));
1607 -- Set the type of the counter explicitly to prevent errors when
1608 -- examining object declarations later on.
1610 Set_Etype
(Counter_Id
, Counter_Typ
);
1612 if Debug_Generated_Code
then
1613 Set_Debug_Info_Needed
(Counter_Id
);
1616 -- The counter and its type are inserted before the source
1617 -- declarations of N.
1619 Prepend_To
(Decls
, Counter_Decl
);
1620 Prepend_To
(Decls
, Counter_Typ_Decl
);
1622 -- The counter and its associated type must be manually analyzed
1623 -- since N has already been analyzed. Use the scope of the spec
1624 -- when inserting in a package.
1627 Push_Scope
(Spec_Id
);
1628 Analyze
(Counter_Typ_Decl
);
1629 Analyze
(Counter_Decl
);
1633 Analyze
(Counter_Typ_Decl
);
1634 Analyze
(Counter_Decl
);
1637 Jump_Alts
:= New_List
;
1640 -- If the context requires additional cleanup, the finalization
1641 -- machinery is added after the cleanup code.
1643 if Acts_As_Clean
then
1644 Finalizer_Stmts
:= Clean_Stmts
;
1645 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1647 Finalizer_Stmts
:= New_List
;
1650 if Has_Tagged_Types
then
1651 Tagged_Type_Stmts
:= New_List
;
1653 end Build_Components
;
1655 ----------------------
1656 -- Create_Finalizer --
1657 ----------------------
1659 procedure Create_Finalizer
is
1660 Body_Id
: Entity_Id
;
1663 Jump_Block
: Node_Id
;
1665 Label_Id
: Entity_Id
;
1668 -- Step 1: Creation of the finalizer name
1670 -- Packages must use a distinct name for their finalizers since the
1671 -- binder will have to generate calls to them by name. The name is
1672 -- of the following form:
1674 -- xx__yy__finalize_[spec|body]
1677 Fin_Id
:= Make_Defining_Identifier
1678 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1679 Set_Has_Qualified_Name
(Fin_Id
);
1680 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1682 -- The default name is _finalizer
1685 -- Generation of a finalization procedure exclusively for 'Old
1686 -- interally generated constants requires different name since
1687 -- there will need to be multiple finalization routines in the
1688 -- same scope. See Build_Finalizer for details.
1690 if Finalize_Old_Only
then
1692 Make_Defining_Identifier
(Loc
,
1693 Chars
=> New_External_Name
(Name_uFinalizer_Old
));
1696 Make_Defining_Identifier
(Loc
,
1697 Chars
=> New_External_Name
(Name_uFinalizer
));
1700 -- The visibility semantics of AT_END handlers force a strange
1701 -- separation of spec and body for stack-related finalizers:
1703 -- declare : Enclosing_Scope
1704 -- procedure _finalizer;
1706 -- <controlled objects>
1707 -- procedure _finalizer is
1713 -- Both spec and body are within the same construct and scope, but
1714 -- the body is part of the handled sequence of statements. This
1715 -- placement confuses the elaboration mechanism on targets where
1716 -- AT_END handlers are expanded into "when all others" handlers:
1719 -- when all others =>
1720 -- _finalizer; -- appears to require elab checks
1725 -- Since the compiler guarantees that the body of a _finalizer is
1726 -- always inserted in the same construct where the AT_END handler
1727 -- resides, there is no need for elaboration checks.
1729 Set_Kill_Elaboration_Checks
(Fin_Id
);
1731 -- Inlining the finalizer produces a substantial speedup at -O2.
1732 -- It is inlined by default at -O3. Either way, it is called
1733 -- exactly twice (once on the normal path, and once for
1734 -- exceptions/abort), so this won't bloat the code too much.
1736 Set_Is_Inlined
(Fin_Id
);
1739 if Debug_Generated_Code
then
1740 Set_Debug_Info_Needed
(Fin_Id
);
1743 -- Step 2: Creation of the finalizer specification
1746 -- procedure Fin_Id;
1749 Make_Subprogram_Declaration
(Loc
,
1751 Make_Procedure_Specification
(Loc
,
1752 Defining_Unit_Name
=> Fin_Id
));
1755 Set_Is_Exported
(Fin_Id
);
1756 Set_Interface_Name
(Fin_Id
,
1757 Make_String_Literal
(Loc
,
1758 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1761 -- Step 3: Creation of the finalizer body
1763 -- Has_Ctrl_Objs might be set because of a generic package body having
1764 -- controlled objects. In this case, Jump_Alts may be empty and no
1765 -- case nor goto statements are needed.
1768 and then not Is_Empty_List
(Jump_Alts
)
1770 -- Add L0, the default destination to the jump block
1772 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1773 Set_Entity
(Label_Id
,
1774 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1775 Label
:= Make_Label
(Loc
, Label_Id
);
1780 Prepend_To
(Finalizer_Decls
,
1781 Make_Implicit_Label_Declaration
(Loc
,
1782 Defining_Identifier
=> Entity
(Label_Id
),
1783 Label_Construct
=> Label
));
1789 Append_To
(Jump_Alts
,
1790 Make_Case_Statement_Alternative
(Loc
,
1791 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1792 Statements
=> New_List
(
1793 Make_Goto_Statement
(Loc
,
1794 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1799 Append_To
(Finalizer_Stmts
, Label
);
1801 -- Create the jump block which controls the finalization flow
1802 -- depending on the value of the state counter.
1805 Make_Case_Statement
(Loc
,
1806 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1807 Alternatives
=> Jump_Alts
);
1809 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1810 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1812 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1816 -- Add the library-level tagged type unregistration machinery before
1817 -- the jump block circuitry. This ensures that external tags will be
1818 -- removed even if a finalization exception occurs at some point.
1820 if Has_Tagged_Types
then
1821 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1824 -- Add a call to the previous At_End handler if it exists. The call
1825 -- must always precede the jump block.
1827 if Present
(Prev_At_End
) then
1828 Prepend_To
(Finalizer_Stmts
,
1829 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1831 -- Clear the At_End handler since we have already generated the
1832 -- proper replacement call for it.
1834 Set_At_End_Proc
(HSS
, Empty
);
1837 -- Release the secondary stack
1839 if Present
(Mark_Id
) then
1841 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1844 -- If the context is a build-in-place function, the secondary
1845 -- stack must be released, unless the build-in-place function
1846 -- itself is returning on the secondary stack. Generate:
1848 -- if BIP_Alloc_Form /= Secondary_Stack then
1849 -- SS_Release (Mark_Id);
1852 -- Note that if the function returns on the secondary stack,
1853 -- then the responsibility of reclaiming the space is always
1854 -- left to the caller (recursively if needed).
1856 if Nkind
(N
) = N_Subprogram_Body
then
1858 Spec_Id
: constant Entity_Id
:=
1859 Unique_Defining_Entity
(N
);
1860 BIP_SS
: constant Boolean :=
1861 Is_Build_In_Place_Function
(Spec_Id
)
1862 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1866 Make_If_Statement
(Loc
,
1871 (Build_In_Place_Formal
1872 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1874 Make_Integer_Literal
(Loc
,
1876 (BIP_Allocation_Form
'Pos
1877 (Secondary_Stack
)))),
1879 Then_Statements
=> New_List
(Release
));
1884 Append_To
(Finalizer_Stmts
, Release
);
1888 -- Protect the statements with abort defer/undefer. This is only when
1889 -- aborts are allowed and the cleanup statements require deferral or
1890 -- there are controlled objects to be finalized. Note that the abort
1891 -- defer/undefer pair does not require an extra block because each
1892 -- finalization exception is caught in its corresponding finalization
1893 -- block. As a result, the call to Abort_Defer always takes place.
1895 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1896 Prepend_To
(Finalizer_Stmts
,
1897 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1899 Append_To
(Finalizer_Stmts
,
1900 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1903 -- The local exception does not need to be reraised for library-level
1904 -- finalizers. Note that this action must be carried out after object
1905 -- cleanup, secondary stack release, and abort undeferral. Generate:
1907 -- if Raised and then not Abort then
1908 -- Raise_From_Controlled_Operation (E);
1911 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1912 Append_To
(Finalizer_Stmts
,
1913 Build_Raise_Statement
(Finalizer_Data
));
1917 -- procedure Fin_Id is
1918 -- Abort : constant Boolean := Triggered_By_Abort;
1920 -- Abort : constant Boolean := False; -- no abort
1922 -- E : Exception_Occurrence; -- All added if flag
1923 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1929 -- Abort_Defer; -- Added if abort is allowed
1930 -- <call to Prev_At_End> -- Added if exists
1931 -- <cleanup statements> -- Added if Acts_As_Clean
1932 -- <jump block> -- Added if Has_Ctrl_Objs
1933 -- <finalization statements> -- Added if Has_Ctrl_Objs
1934 -- <stack release> -- Added if Mark_Id exists
1935 -- Abort_Undefer; -- Added if abort is allowed
1936 -- <exception propagation> -- Added if Has_Ctrl_Objs
1939 -- Create the body of the finalizer
1941 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1943 if Debug_Generated_Code
then
1944 Set_Debug_Info_Needed
(Body_Id
);
1948 Set_Has_Qualified_Name
(Body_Id
);
1949 Set_Has_Fully_Qualified_Name
(Body_Id
);
1953 Make_Subprogram_Body
(Loc
,
1955 Make_Procedure_Specification
(Loc
,
1956 Defining_Unit_Name
=> Body_Id
),
1957 Declarations
=> Finalizer_Decls
,
1958 Handled_Statement_Sequence
=>
1959 Make_Handled_Sequence_Of_Statements
(Loc
,
1960 Statements
=> Finalizer_Stmts
));
1962 -- Step 4: Spec and body insertion, analysis
1966 -- If the package spec has private declarations, the finalizer
1967 -- body must be added to the end of the list in order to have
1968 -- visibility of all private controlled objects.
1970 if For_Package_Spec
then
1971 if Present
(Priv_Decls
) then
1972 Append_To
(Priv_Decls
, Fin_Spec
);
1973 Append_To
(Priv_Decls
, Fin_Body
);
1975 Append_To
(Decls
, Fin_Spec
);
1976 Append_To
(Decls
, Fin_Body
);
1979 -- For package bodies, both the finalizer spec and body are
1980 -- inserted at the end of the package declarations.
1983 Append_To
(Decls
, Fin_Spec
);
1984 Append_To
(Decls
, Fin_Body
);
1987 -- Push the name of the package
1989 Push_Scope
(Spec_Id
);
1997 -- Create the spec for the finalizer. The At_End handler must be
1998 -- able to call the body which resides in a nested structure.
2002 -- procedure Fin_Id; -- Spec
2004 -- <objects and possibly statements>
2005 -- procedure Fin_Id is ... -- Body
2008 -- Fin_Id; -- At_End handler
2011 pragma Assert
(Present
(Spec_Decls
));
2013 -- It maybe possible that we are finalizing 'Old objects which
2014 -- exist in the spec declarations. When this is the case the
2015 -- Finalizer_Insert_Node will come before the end of the
2016 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
2017 -- earlier at the Finalizer_Insert_Nod instead of appending to the
2018 -- end of Spec_Decls to prevent its body appearing before its
2019 -- corresponding spec.
2021 if Present
(Finalizer_Insert_Nod
)
2022 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
2024 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
2025 Finalizer_Insert_Nod
:= Fin_Spec
;
2027 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
2030 Append_To
(Spec_Decls
, Fin_Spec
);
2034 -- When the finalizer acts solely as a cleanup routine, the body
2035 -- is inserted right after the spec.
2037 if Acts_As_Clean
and not Has_Ctrl_Objs
then
2038 Insert_After
(Fin_Spec
, Fin_Body
);
2040 -- In all other cases the body is inserted after either:
2042 -- 1) The counter update statement of the last controlled object
2043 -- 2) The last top level nested controlled package
2044 -- 3) The last top level controlled instantiation
2047 -- Manually freeze the spec. This is somewhat of a hack because
2048 -- a subprogram is frozen when its body is seen and the freeze
2049 -- node appears right before the body. However, in this case,
2050 -- the spec must be frozen earlier since the At_End handler
2051 -- must be able to call it.
2054 -- procedure Fin_Id; -- Spec
2055 -- [Fin_Id] -- Freeze node
2059 -- Fin_Id; -- At_End handler
2062 Ensure_Freeze_Node
(Fin_Id
);
2063 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2064 Set_Is_Frozen
(Fin_Id
);
2066 -- In the case where the last construct to contain a controlled
2067 -- object is either a nested package, an instantiation or a
2068 -- freeze node, the body must be inserted directly after the
2071 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2072 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2074 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2077 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2080 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2083 -- Never consider that the finalizer procedure is enabled Ghost, even
2084 -- when the corresponding unit is Ghost, as this would lead to an
2085 -- an external name with a ___ghost_ prefix that the binder cannot
2086 -- generate, as it has no knowledge of the Ghost status of units.
2088 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2089 end Create_Finalizer
;
2091 ------------------------
2092 -- New_Finalizer_Name --
2093 ------------------------
2095 function New_Finalizer_Name
2096 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2098 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2099 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2100 -- has a non-standard scope, process the scope first.
2102 ------------------------
2103 -- New_Finalizer_Name --
2104 ------------------------
2106 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2108 if Scope
(Id
) = Standard_Standard
then
2109 Get_Name_String
(Chars
(Id
));
2112 New_Finalizer_Name
(Scope
(Id
));
2113 Add_Str_To_Name_Buffer
("__");
2114 Get_Name_String_And_Append
(Chars
(Id
));
2116 end New_Finalizer_Name
;
2118 -- Start of processing for New_Finalizer_Name
2121 -- Create the fully qualified name of the enclosing scope
2123 New_Finalizer_Name
(Spec_Id
);
2126 -- __finalize_[spec|body]
2128 Add_Str_To_Name_Buffer
("__finalize_");
2131 Add_Str_To_Name_Buffer
("spec");
2133 Add_Str_To_Name_Buffer
("body");
2137 end New_Finalizer_Name
;
2139 --------------------------
2140 -- Process_Declarations --
2141 --------------------------
2143 procedure Process_Declarations
2145 Preprocess
: Boolean := False;
2146 Top_Level
: Boolean := False)
2151 Obj_Typ
: Entity_Id
;
2152 Pack_Id
: Entity_Id
;
2156 Old_Counter_Val
: Nat
;
2157 -- This variable is used to determine whether a nested package or
2158 -- instance contains at least one controlled object.
2160 procedure Processing_Actions
2161 (Has_No_Init
: Boolean := False;
2162 Is_Protected
: Boolean := False);
2163 -- Depending on the mode of operation of Process_Declarations, either
2164 -- increment the controlled object counter, set the controlled object
2165 -- flag and store the last top level construct or process the current
2166 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2167 -- the current declaration may not have initialization proc(s). Flag
2168 -- Is_Protected should be set when the current declaration denotes a
2169 -- simple protected object.
2171 ------------------------
2172 -- Processing_Actions --
2173 ------------------------
2175 procedure Processing_Actions
2176 (Has_No_Init
: Boolean := False;
2177 Is_Protected
: Boolean := False)
2180 -- Library-level tagged type
2182 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2184 Has_Tagged_Types
:= True;
2186 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2187 Last_Top_Level_Ctrl_Construct
:= Decl
;
2190 -- Unregister tagged type, unless No_Tagged_Type_Registration
2193 elsif not Restriction_Active
(No_Tagged_Type_Registration
) then
2194 Process_Tagged_Type_Declaration
(Decl
);
2197 -- Controlled object declaration
2201 Counter_Val
:= Counter_Val
+ 1;
2202 Has_Ctrl_Objs
:= True;
2204 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2205 Last_Top_Level_Ctrl_Construct
:= Decl
;
2209 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2212 end Processing_Actions
;
2214 -- Start of processing for Process_Declarations
2217 if Is_Empty_List
(Decls
) then
2221 -- Process all declarations in reverse order
2223 Decl
:= Last_Non_Pragma
(Decls
);
2224 while Present
(Decl
) loop
2225 -- Depending on the value of flag Finalize_Old_Only we determine
2226 -- which objects get finalized as part of the current finalizer
2229 -- When True, only temporaries capturing the value of attribute
2230 -- 'Old are finalized and all other cases are ignored.
2232 -- When False, temporary objects used to capture the value of 'Old
2233 -- are ignored and all others are considered.
2235 if Finalize_Old_Only
2236 xor (Nkind
(Decl
) = N_Object_Declaration
2237 and then Stores_Attribute_Old_Prefix
2238 (Defining_Identifier
(Decl
)))
2242 -- Library-level tagged types
2244 elsif Nkind
(Decl
) = N_Full_Type_Declaration
then
2245 Typ
:= Defining_Identifier
(Decl
);
2247 -- Ignored Ghost types do not need any cleanup actions because
2248 -- they will not appear in the final tree.
2250 if Is_Ignored_Ghost_Entity
(Typ
) then
2253 elsif Is_Tagged_Type
(Typ
)
2254 and then Is_Library_Level_Entity
(Typ
)
2255 and then Convention
(Typ
) = Convention_Ada
2256 and then Present
(Access_Disp_Table
(Typ
))
2257 and then not Is_Abstract_Type
(Typ
)
2258 and then not No_Run_Time_Mode
2259 and then not Restriction_Active
(No_Tagged_Type_Registration
)
2260 and then RTE_Available
(RE_Register_Tag
)
2265 -- Regular object declarations
2267 elsif Nkind
(Decl
) = N_Object_Declaration
then
2268 Obj_Id
:= Defining_Identifier
(Decl
);
2269 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2270 Expr
:= Expression
(Decl
);
2272 -- Bypass any form of processing for objects which have their
2273 -- finalization disabled. This applies only to objects at the
2276 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2279 -- Finalization of transient objects are treated separately in
2280 -- order to handle sensitive cases. These include:
2282 -- * Aggregate expansion
2283 -- * If, case, and expression with actions expansion
2284 -- * Transient scopes
2286 -- If one of those contexts has marked the transient object as
2287 -- ignored, do not generate finalization actions for it.
2289 elsif Is_Finalized_Transient
(Obj_Id
)
2290 or else Is_Ignored_Transient
(Obj_Id
)
2294 -- Ignored Ghost objects do not need any cleanup actions
2295 -- because they will not appear in the final tree.
2297 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2300 -- The object is of the form:
2301 -- Obj : [constant] Typ [:= Expr];
2303 -- Do not process tag-to-class-wide conversions because they do
2304 -- not yield an object. Do not process the incomplete view of a
2305 -- deferred constant. Note that an object initialized by means
2306 -- of a build-in-place function call may appear as a deferred
2307 -- constant after expansion activities. These kinds of objects
2308 -- must be finalized.
2310 elsif not Is_Imported
(Obj_Id
)
2311 and then Needs_Finalization
(Obj_Typ
)
2312 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2313 and then not (Ekind
(Obj_Id
) = E_Constant
2314 and then not Has_Completion
(Obj_Id
)
2315 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2319 -- The object is of the form:
2320 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2322 -- Obj : Access_Typ :=
2323 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2325 elsif Is_Access_Type
(Obj_Typ
)
2326 and then Needs_Finalization
2327 (Available_View
(Designated_Type
(Obj_Typ
)))
2328 and then Present
(Expr
)
2330 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2332 (Is_Non_BIP_Func_Call
(Expr
)
2333 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2335 Processing_Actions
(Has_No_Init
=> True);
2337 -- Processing for "hook" objects generated for transient
2338 -- objects declared inside an Expression_With_Actions.
2340 elsif Is_Access_Type
(Obj_Typ
)
2341 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2342 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2343 N_Object_Declaration
2345 Processing_Actions
(Has_No_Init
=> True);
2347 -- Process intermediate results of an if expression with one
2348 -- of the alternatives using a controlled function call.
2350 elsif Is_Access_Type
(Obj_Typ
)
2351 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2352 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2353 N_Defining_Identifier
2354 and then Present
(Expr
)
2355 and then Nkind
(Expr
) = N_Null
2357 Processing_Actions
(Has_No_Init
=> True);
2359 -- Simple protected objects which use type System.Tasking.
2360 -- Protected_Objects.Protection to manage their locks should
2361 -- be treated as controlled since they require manual cleanup.
2362 -- The only exception is illustrated in the following example:
2365 -- type Ctrl is new Controlled ...
2366 -- procedure Finalize (Obj : in out Ctrl);
2370 -- package body Pkg is
2371 -- protected Prot is
2372 -- procedure Do_Something (Obj : in out Ctrl);
2375 -- protected body Prot is
2376 -- procedure Do_Something (Obj : in out Ctrl) is ...
2379 -- procedure Finalize (Obj : in out Ctrl) is
2381 -- Prot.Do_Something (Obj);
2385 -- Since for the most part entities in package bodies depend on
2386 -- those in package specs, Prot's lock should be cleaned up
2387 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2388 -- This act however attempts to invoke Do_Something and fails
2389 -- because the lock has disappeared.
2391 elsif Ekind
(Obj_Id
) = E_Variable
2392 and then not In_Library_Level_Package_Body
(Obj_Id
)
2393 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2394 or else Has_Simple_Protected_Object
(Obj_Typ
))
2396 Processing_Actions
(Is_Protected
=> True);
2399 -- Specific cases of object renamings
2401 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2402 Obj_Id
:= Defining_Identifier
(Decl
);
2403 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2405 -- Bypass any form of processing for objects which have their
2406 -- finalization disabled. This applies only to objects at the
2409 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2412 -- Ignored Ghost object renamings do not need any cleanup
2413 -- actions because they will not appear in the final tree.
2415 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2418 -- Return object of a build-in-place function. This case is
2419 -- recognized and marked by the expansion of an extended return
2420 -- statement (see Expand_N_Extended_Return_Statement).
2422 elsif Needs_Finalization
(Obj_Typ
)
2423 and then Is_Return_Object
(Obj_Id
)
2424 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2426 Processing_Actions
(Has_No_Init
=> True);
2428 -- Detect a case where a source object has been initialized by
2429 -- a controlled function call or another object which was later
2430 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2432 -- Obj1 : CW_Type := Src_Obj;
2433 -- Obj2 : CW_Type := Function_Call (...);
2435 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2436 -- Tmp : ... := Function_Call (...)'reference;
2437 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2439 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2440 Processing_Actions
(Has_No_Init
=> True);
2443 -- Inspect the freeze node of an access-to-controlled type and
2444 -- look for a delayed finalization master. This case arises when
2445 -- the freeze actions are inserted at a later time than the
2446 -- expansion of the context. Since Build_Finalizer is never called
2447 -- on a single construct twice, the master will be ultimately
2448 -- left out and never finalized. This is also needed for freeze
2449 -- actions of designated types themselves, since in some cases the
2450 -- finalization master is associated with a designated type's
2451 -- freeze node rather than that of the access type (see handling
2452 -- for freeze actions in Build_Finalization_Master).
2454 elsif Nkind
(Decl
) = N_Freeze_Entity
2455 and then Present
(Actions
(Decl
))
2457 Typ
:= Entity
(Decl
);
2459 -- Freeze nodes for ignored Ghost types do not need cleanup
2460 -- actions because they will never appear in the final tree.
2462 if Is_Ignored_Ghost_Entity
(Typ
) then
2465 elsif (Is_Access_Object_Type
(Typ
)
2466 and then Needs_Finalization
2467 (Available_View
(Designated_Type
(Typ
))))
2468 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2470 Old_Counter_Val
:= Counter_Val
;
2472 -- Freeze nodes are considered to be identical to packages
2473 -- and blocks in terms of nesting. The difference is that
2474 -- a finalization master created inside the freeze node is
2475 -- at the same nesting level as the node itself.
2477 Process_Declarations
(Actions
(Decl
), Preprocess
);
2479 -- The freeze node contains a finalization master
2483 and then No
(Last_Top_Level_Ctrl_Construct
)
2484 and then Counter_Val
> Old_Counter_Val
2486 Last_Top_Level_Ctrl_Construct
:= Decl
;
2490 -- Nested package declarations, avoid generics
2492 elsif Nkind
(Decl
) = N_Package_Declaration
then
2493 Pack_Id
:= Defining_Entity
(Decl
);
2494 Spec
:= Specification
(Decl
);
2496 -- Do not inspect an ignored Ghost package because all code
2497 -- found within will not appear in the final tree.
2499 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2502 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2503 Old_Counter_Val
:= Counter_Val
;
2504 Process_Declarations
2505 (Private_Declarations
(Spec
), Preprocess
);
2506 Process_Declarations
2507 (Visible_Declarations
(Spec
), Preprocess
);
2509 -- Either the visible or the private declarations contain a
2510 -- controlled object. The nested package declaration is the
2511 -- last such construct.
2515 and then No
(Last_Top_Level_Ctrl_Construct
)
2516 and then Counter_Val
> Old_Counter_Val
2518 Last_Top_Level_Ctrl_Construct
:= Decl
;
2522 -- Call the xxx__finalize_body procedure of a library level
2523 -- package instantiation if the body contains finalization
2526 if Present
(Generic_Parent
(Spec
))
2527 and then Is_Library_Level_Entity
(Pack_Id
)
2528 and then Present
(Body_Entity
(Generic_Parent
(Spec
)))
2534 P
:= Parent
(Body_Entity
(Generic_Parent
(Spec
)));
2536 and then Nkind
(P
) /= N_Package_Body
2542 Old_Counter_Val
:= Counter_Val
;
2543 Process_Declarations
(Declarations
(P
), Preprocess
);
2545 -- Note that we are processing the generic body
2546 -- template and not the actually instantiation
2547 -- (which is generated too late for us to process
2548 -- it), so there is no need to update in particular
2549 -- to update Last_Top_Level_Ctrl_Construct here.
2551 if Counter_Val
> Old_Counter_Val
then
2552 Counter_Val
:= Old_Counter_Val
;
2553 Set_Has_Controlled_Component
(Pack_Id
);
2558 elsif Has_Controlled_Component
(Pack_Id
) then
2560 -- We import the xxx__finalize_body routine since the
2561 -- generic body will be instantiated later.
2564 Id
: constant Node_Id
:=
2565 Make_Defining_Identifier
(Loc
,
2566 New_Finalizer_Name
(Defining_Unit_Name
(Spec
),
2567 For_Spec
=> False));
2570 Set_Has_Qualified_Name
(Id
);
2571 Set_Has_Fully_Qualified_Name
(Id
);
2572 Set_Is_Imported
(Id
);
2573 Set_Has_Completion
(Id
);
2574 Set_Interface_Name
(Id
,
2575 Make_String_Literal
(Loc
,
2576 Strval
=> Get_Name_String
(Chars
(Id
))));
2578 Append_New_To
(Finalizer_Stmts
,
2579 Make_Subprogram_Declaration
(Loc
,
2580 Make_Procedure_Specification
(Loc
,
2581 Defining_Unit_Name
=> Id
)));
2582 Append_To
(Finalizer_Stmts
,
2583 Make_Procedure_Call_Statement
(Loc
,
2584 Name
=> New_Occurrence_Of
(Id
, Loc
)));
2589 -- Nested package bodies, avoid generics
2591 elsif Nkind
(Decl
) = N_Package_Body
then
2593 -- Do not inspect an ignored Ghost package body because all
2594 -- code found within will not appear in the final tree.
2596 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2599 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
2601 Old_Counter_Val
:= Counter_Val
;
2602 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2604 -- The nested package body is the last construct to contain
2605 -- a controlled object.
2609 and then No
(Last_Top_Level_Ctrl_Construct
)
2610 and then Counter_Val
> Old_Counter_Val
2612 Last_Top_Level_Ctrl_Construct
:= Decl
;
2616 -- Handle a rare case caused by a controlled transient object
2617 -- created as part of a record init proc. The variable is wrapped
2618 -- in a block, but the block is not associated with a transient
2621 elsif Nkind
(Decl
) = N_Block_Statement
2622 and then Inside_Init_Proc
2624 Old_Counter_Val
:= Counter_Val
;
2626 if Present
(Handled_Statement_Sequence
(Decl
)) then
2627 Process_Declarations
2628 (Statements
(Handled_Statement_Sequence
(Decl
)),
2632 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2634 -- Either the declaration or statement list of the block has a
2635 -- controlled object.
2639 and then No
(Last_Top_Level_Ctrl_Construct
)
2640 and then Counter_Val
> Old_Counter_Val
2642 Last_Top_Level_Ctrl_Construct
:= Decl
;
2645 -- Handle the case where the original context has been wrapped in
2646 -- a block to avoid interference between exception handlers and
2647 -- At_End handlers. Treat the block as transparent and process its
2650 elsif Nkind
(Decl
) = N_Block_Statement
2651 and then Is_Finalization_Wrapper
(Decl
)
2653 if Present
(Handled_Statement_Sequence
(Decl
)) then
2654 Process_Declarations
2655 (Statements
(Handled_Statement_Sequence
(Decl
)),
2659 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2662 Prev_Non_Pragma
(Decl
);
2664 end Process_Declarations
;
2666 --------------------------------
2667 -- Process_Object_Declaration --
2668 --------------------------------
2670 procedure Process_Object_Declaration
2672 Has_No_Init
: Boolean := False;
2673 Is_Protected
: Boolean := False)
2675 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2676 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2678 Init_Typ
: Entity_Id
;
2679 -- The initialization type of the related object declaration. Note
2680 -- that this is not necessarily the same type as Obj_Typ because of
2681 -- possible type derivations.
2683 Obj_Typ
: Entity_Id
;
2684 -- The type of the related object declaration
2686 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2687 -- Func_Id denotes a build-in-place function. Generate the following
2690 -- if BIPallocfrom > Secondary_Stack'Pos
2691 -- and then BIPfinalizationmaster /= null
2694 -- type Ptr_Typ is access Obj_Typ;
2695 -- for Ptr_Typ'Storage_Pool
2696 -- use Base_Pool (BIPfinalizationmaster);
2698 -- Free (Ptr_Typ (Temp));
2702 -- Obj_Typ is the type of the current object, Temp is the original
2703 -- allocation which Obj_Id renames.
2705 procedure Find_Last_Init
2706 (Last_Init
: out Node_Id
;
2707 Body_Insert
: out Node_Id
);
2708 -- Find the last initialization call related to object declaration
2709 -- Decl. Last_Init denotes the last initialization call which follows
2710 -- Decl. Body_Insert denotes a node where the finalizer body could be
2711 -- potentially inserted after (if blocks are involved).
2713 -----------------------------
2714 -- Build_BIP_Cleanup_Stmts --
2715 -----------------------------
2717 function Build_BIP_Cleanup_Stmts
2718 (Func_Id
: Entity_Id
) return Node_Id
2720 Decls
: constant List_Id
:= New_List
;
2721 Fin_Mas_Id
: constant Entity_Id
:=
2722 Build_In_Place_Formal
2723 (Func_Id
, BIP_Finalization_Master
);
2724 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2725 Temp_Id
: constant Entity_Id
:=
2726 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2730 Free_Stmt
: Node_Id
;
2731 Pool_Id
: Entity_Id
;
2732 Ptr_Typ
: Entity_Id
;
2736 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2738 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2741 Make_Object_Renaming_Declaration
(Loc
,
2742 Defining_Identifier
=> Pool_Id
,
2744 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2746 Make_Explicit_Dereference
(Loc
,
2748 Make_Function_Call
(Loc
,
2750 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2751 Parameter_Associations
=> New_List
(
2752 Make_Explicit_Dereference
(Loc
,
2754 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2756 -- Create an access type which uses the storage pool of the
2757 -- caller's finalization master.
2760 -- type Ptr_Typ is access Func_Typ;
2762 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2765 Make_Full_Type_Declaration
(Loc
,
2766 Defining_Identifier
=> Ptr_Typ
,
2768 Make_Access_To_Object_Definition
(Loc
,
2769 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2771 -- Perform minor decoration in order to set the master and the
2772 -- storage pool attributes.
2774 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2775 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2776 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2778 if Debug_Generated_Code
then
2779 Set_Debug_Info_Needed
(Pool_Id
);
2782 -- Create an explicit free statement. Note that the free uses the
2783 -- caller's pool expressed as a renaming.
2786 Make_Free_Statement
(Loc
,
2788 Unchecked_Convert_To
(Ptr_Typ
,
2789 New_Occurrence_Of
(Temp_Id
, Loc
)));
2791 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2793 -- Create a block to house the dummy type and the instantiation as
2794 -- well as to perform the cleanup the temporary.
2800 -- Free (Ptr_Typ (Temp_Id));
2804 Make_Block_Statement
(Loc
,
2805 Declarations
=> Decls
,
2806 Handled_Statement_Sequence
=>
2807 Make_Handled_Sequence_Of_Statements
(Loc
,
2808 Statements
=> New_List
(Free_Stmt
)));
2811 -- if BIPfinalizationmaster /= null then
2815 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2816 Right_Opnd
=> Make_Null
(Loc
));
2818 -- For unconstrained or tagged results, escalate the condition to
2819 -- include the allocation format. Generate:
2821 -- if BIPallocform > Secondary_Stack'Pos
2822 -- and then BIPfinalizationmaster /= null
2825 if Needs_BIP_Alloc_Form
(Func_Id
) then
2827 Alloc
: constant Entity_Id
:=
2828 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2834 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2836 Make_Integer_Literal
(Loc
,
2838 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2840 Right_Opnd
=> Cond
);
2850 Make_If_Statement
(Loc
,
2852 Then_Statements
=> New_List
(Free_Blk
));
2853 end Build_BIP_Cleanup_Stmts
;
2855 --------------------
2856 -- Find_Last_Init --
2857 --------------------
2859 procedure Find_Last_Init
2860 (Last_Init
: out Node_Id
;
2861 Body_Insert
: out Node_Id
)
2863 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2864 -- Find the last initialization call within the statements of
2867 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2868 -- Determine whether node N denotes one of the initialization
2869 -- procedures of types Init_Typ or Obj_Typ.
2871 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2872 -- Obtain the next statement which follows list member Stmt while
2873 -- ignoring artifacts related to access-before-elaboration checks.
2875 -----------------------------
2876 -- Find_Last_Init_In_Block --
2877 -----------------------------
2879 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2880 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2884 -- Examine the individual statements of the block in reverse to
2885 -- locate the last initialization call.
2887 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2888 Stmt
:= Last
(Statements
(HSS
));
2889 while Present
(Stmt
) loop
2891 -- Peek inside nested blocks in case aborts are allowed
2893 if Nkind
(Stmt
) = N_Block_Statement
then
2894 return Find_Last_Init_In_Block
(Stmt
);
2896 elsif Is_Init_Call
(Stmt
) then
2905 end Find_Last_Init_In_Block
;
2911 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2912 function Is_Init_Proc_Of
2913 (Subp_Id
: Entity_Id
;
2914 Typ
: Entity_Id
) return Boolean;
2915 -- Determine whether subprogram Subp_Id is a valid init proc of
2918 ---------------------
2919 -- Is_Init_Proc_Of --
2920 ---------------------
2922 function Is_Init_Proc_Of
2923 (Subp_Id
: Entity_Id
;
2924 Typ
: Entity_Id
) return Boolean
2926 Deep_Init
: Entity_Id
:= Empty
;
2927 Prim_Init
: Entity_Id
:= Empty
;
2928 Type_Init
: Entity_Id
:= Empty
;
2931 -- Obtain all possible initialization routines of the
2932 -- related type and try to match the subprogram entity
2933 -- against one of them.
2937 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2939 -- Primitive Initialize
2941 if Is_Controlled
(Typ
) then
2942 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2944 if Present
(Prim_Init
) then
2945 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2949 -- Type initialization routine
2951 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2952 Type_Init
:= Base_Init_Proc
(Typ
);
2956 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2958 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2960 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2961 end Is_Init_Proc_Of
;
2965 Call_Id
: Entity_Id
;
2967 -- Start of processing for Is_Init_Call
2970 if Nkind
(N
) = N_Procedure_Call_Statement
2971 and then Nkind
(Name
(N
)) = N_Identifier
2973 Call_Id
:= Entity
(Name
(N
));
2975 -- Consider both the type of the object declaration and its
2976 -- related initialization type.
2979 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2981 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2987 -----------------------------
2988 -- Next_Suitable_Statement --
2989 -----------------------------
2991 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2995 -- Skip call markers and Program_Error raises installed by the
2998 Result
:= Next
(Stmt
);
2999 while Present
(Result
) loop
3000 exit when Nkind
(Result
) not in
3001 N_Call_Marker | N_Raise_Program_Error
;
3007 end Next_Suitable_Statement
;
3015 Deep_Init_Found
: Boolean := False;
3016 -- A flag set when a call to [Deep_]Initialize has been found
3018 -- Start of processing for Find_Last_Init
3022 Body_Insert
:= Empty
;
3024 -- Object renamings and objects associated with controlled
3025 -- function results do not require initialization.
3031 Stmt
:= Next_Suitable_Statement
(Decl
);
3033 -- For an object with suppressed initialization, we check whether
3034 -- there is in fact no initialization expression. If there is not,
3035 -- then this is an object declaration that has been turned into a
3036 -- different object declaration that calls the build-in-place
3037 -- function in a 'Reference attribute, as in "F(...)'Reference".
3038 -- We search for that later object declaration, so that the
3039 -- Inc_Decl will be inserted after the call. Otherwise, if the
3040 -- call raises an exception, we will finalize the (uninitialized)
3041 -- object, which is wrong.
3043 if No_Initialization
(Decl
) then
3044 if No
(Expression
(Last_Init
)) then
3047 exit when No
(Last_Init
);
3048 exit when Nkind
(Last_Init
) = N_Object_Declaration
3049 and then Nkind
(Expression
(Last_Init
)) = N_Reference
3050 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
3052 and then Is_Expanded_Build_In_Place_Call
3053 (Prefix
(Expression
(Last_Init
)));
3059 -- If the initialization is in the declaration, we're done, so
3060 -- early return if we have no more statements or they have been
3061 -- rewritten, which means that they were in the source code.
3063 elsif No
(Stmt
) or else Original_Node
(Stmt
) /= Stmt
then
3066 -- In all other cases the initialization calls follow the related
3067 -- object. The general structure of object initialization built by
3068 -- routine Default_Initialize_Object is as follows:
3070 -- [begin -- aborts allowed
3072 -- Type_Init_Proc (Obj);
3073 -- [begin] -- exceptions allowed
3074 -- Deep_Initialize (Obj);
3075 -- [exception -- exceptions allowed
3077 -- Deep_Finalize (Obj, Self => False);
3080 -- [at end -- aborts allowed
3084 -- When aborts are allowed, the initialization calls are housed
3087 elsif Nkind
(Stmt
) = N_Block_Statement
then
3088 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
3089 Body_Insert
:= Stmt
;
3091 -- Otherwise the initialization calls follow the related object
3094 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
3096 -- Check for an optional call to Deep_Initialize which may
3097 -- appear within a block depending on whether the object has
3098 -- controlled components.
3100 if Present
(Stmt_2
) then
3101 if Nkind
(Stmt_2
) = N_Block_Statement
then
3102 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
3104 if Present
(Call
) then
3105 Deep_Init_Found
:= True;
3107 Body_Insert
:= Stmt_2
;
3110 elsif Is_Init_Call
(Stmt_2
) then
3111 Deep_Init_Found
:= True;
3112 Last_Init
:= Stmt_2
;
3113 Body_Insert
:= Last_Init
;
3117 -- If the object lacks a call to Deep_Initialize, then it must
3118 -- have a call to its related type init proc.
3120 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
3122 Body_Insert
:= Last_Init
;
3130 Count_Ins
: Node_Id
;
3132 Fin_Stmts
: List_Id
:= No_List
;
3135 Label_Id
: Entity_Id
;
3138 -- Start of processing for Process_Object_Declaration
3141 -- Handle the object type and the reference to the object
3143 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
3144 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
3147 if Is_Access_Type
(Obj_Typ
) then
3148 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
3149 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
3151 elsif Is_Concurrent_Type
(Obj_Typ
)
3152 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
3154 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
3155 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3157 elsif Is_Private_Type
(Obj_Typ
)
3158 and then Present
(Full_View
(Obj_Typ
))
3160 Obj_Typ
:= Full_View
(Obj_Typ
);
3161 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3163 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3164 Obj_Typ
:= Base_Type
(Obj_Typ
);
3165 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3172 Set_Etype
(Obj_Ref
, Obj_Typ
);
3174 -- Handle the initialization type of the object declaration
3176 Init_Typ
:= Obj_Typ
;
3178 if Is_Private_Type
(Init_Typ
)
3179 and then Present
(Full_View
(Init_Typ
))
3181 Init_Typ
:= Full_View
(Init_Typ
);
3183 elsif Is_Untagged_Derivation
(Init_Typ
) then
3184 Init_Typ
:= Root_Type
(Init_Typ
);
3191 -- Set a new value for the state counter and insert the statement
3192 -- after the object declaration. Generate:
3194 -- Counter := <value>;
3197 Make_Assignment_Statement
(Loc
,
3198 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3199 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3201 -- Insert the counter after all initialization has been done. The
3202 -- place of insertion depends on the context.
3204 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3206 -- The object is initialized by a build-in-place function call.
3207 -- The counter insertion point is after the function call.
3209 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3210 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3213 -- The object is initialized by an aggregate. Insert the counter
3214 -- after the last aggregate assignment.
3216 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3217 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3220 -- In all other cases the counter is inserted after the last call
3221 -- to either [Deep_]Initialize or the type-specific init proc.
3224 Find_Last_Init
(Count_Ins
, Body_Ins
);
3227 -- In all other cases the counter is inserted after the last call to
3228 -- either [Deep_]Initialize or the type-specific init proc.
3231 Find_Last_Init
(Count_Ins
, Body_Ins
);
3234 -- If the Initialize function is null or trivial, the call will have
3235 -- been replaced with a null statement, in which case place counter
3236 -- declaration after object declaration itself.
3238 if No
(Count_Ins
) then
3242 Insert_After
(Count_Ins
, Inc_Decl
);
3245 -- If the current declaration is the last in the list, the finalizer
3246 -- body needs to be inserted after the set counter statement for the
3247 -- current object declaration. This is complicated by the fact that
3248 -- the set counter statement may appear in abort deferred block. In
3249 -- that case, the proper insertion place is after the block.
3251 if No
(Finalizer_Insert_Nod
) then
3253 -- Insertion after an abort deferred block
3255 if Present
(Body_Ins
) then
3256 Finalizer_Insert_Nod
:= Body_Ins
;
3258 Finalizer_Insert_Nod
:= Inc_Decl
;
3262 -- Create the associated label with this object, generate:
3264 -- L<counter> : label;
3267 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3269 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3270 Label
:= Make_Label
(Loc
, Label_Id
);
3272 Prepend_To
(Finalizer_Decls
,
3273 Make_Implicit_Label_Declaration
(Loc
,
3274 Defining_Identifier
=> Entity
(Label_Id
),
3275 Label_Construct
=> Label
));
3277 -- Create the associated jump with this object, generate:
3279 -- when <counter> =>
3282 Prepend_To
(Jump_Alts
,
3283 Make_Case_Statement_Alternative
(Loc
,
3284 Discrete_Choices
=> New_List
(
3285 Make_Integer_Literal
(Loc
, Counter_Val
)),
3286 Statements
=> New_List
(
3287 Make_Goto_Statement
(Loc
,
3288 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3290 -- Insert the jump destination, generate:
3294 Append_To
(Finalizer_Stmts
, Label
);
3296 -- Disable warnings on Obj_Id. This works around an issue where GCC
3297 -- is not able to detect that Obj_Id is protected by a counter and
3298 -- emits spurious warnings.
3300 if not Comes_From_Source
(Obj_Id
) then
3301 Set_Warnings_Off
(Obj_Id
);
3304 -- Processing for simple protected objects. Such objects require
3305 -- manual finalization of their lock managers.
3307 if Is_Protected
then
3308 if Is_Simple_Protected_Type
(Obj_Typ
) then
3309 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3311 if Present
(Fin_Call
) then
3312 Fin_Stmts
:= New_List
(Fin_Call
);
3315 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3316 if Is_Record_Type
(Obj_Typ
) then
3317 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3318 elsif Is_Array_Type
(Obj_Typ
) then
3319 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3325 -- System.Tasking.Protected_Objects.Finalize_Protection
3333 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3334 Fin_Stmts
:= New_List
(
3335 Make_Block_Statement
(Loc
,
3336 Handled_Statement_Sequence
=>
3337 Make_Handled_Sequence_Of_Statements
(Loc
,
3338 Statements
=> Fin_Stmts
,
3340 Exception_Handlers
=> New_List
(
3341 Make_Exception_Handler
(Loc
,
3342 Exception_Choices
=> New_List
(
3343 Make_Others_Choice
(Loc
)),
3345 Statements
=> New_List
(
3346 Make_Null_Statement
(Loc
)))))));
3349 -- Processing for regular controlled objects
3354 -- [Deep_]Finalize (Obj);
3357 -- when Id : others =>
3358 -- if not Raised then
3360 -- Save_Occurrence (E, Id);
3369 -- Guard against a missing [Deep_]Finalize when the object type
3370 -- was not properly frozen.
3372 if No
(Fin_Call
) then
3373 Fin_Call
:= Make_Null_Statement
(Loc
);
3376 -- For CodePeer, the exception handlers normally generated here
3377 -- generate complex flowgraphs which result in capacity problems.
3378 -- Omitting these handlers for CodePeer is justified as follows:
3380 -- If a handler is dead, then omitting it is surely ok
3382 -- If a handler is live, then CodePeer should flag the
3383 -- potentially-exception-raising construct that causes it
3384 -- to be live. That is what we are interested in, not what
3385 -- happens after the exception is raised.
3387 if Exceptions_OK
and not CodePeer_Mode
then
3388 Fin_Stmts
:= New_List
(
3389 Make_Block_Statement
(Loc
,
3390 Handled_Statement_Sequence
=>
3391 Make_Handled_Sequence_Of_Statements
(Loc
,
3392 Statements
=> New_List
(Fin_Call
),
3394 Exception_Handlers
=> New_List
(
3395 Build_Exception_Handler
3396 (Finalizer_Data
, For_Package
)))));
3398 -- When exception handlers are prohibited, the finalization call
3399 -- appears unprotected. Any exception raised during finalization
3400 -- will bypass the circuitry which ensures the cleanup of all
3401 -- remaining objects.
3404 Fin_Stmts
:= New_List
(Fin_Call
);
3407 -- If we are dealing with a return object of a build-in-place
3408 -- function, generate the following cleanup statements:
3410 -- if BIPallocfrom > Secondary_Stack'Pos
3411 -- and then BIPfinalizationmaster /= null
3414 -- type Ptr_Typ is access Obj_Typ;
3415 -- for Ptr_Typ'Storage_Pool use
3416 -- Base_Pool (BIPfinalizationmaster.all).all;
3418 -- Free (Ptr_Typ (Temp));
3422 -- The generated code effectively detaches the temporary from the
3423 -- caller finalization master and deallocates the object.
3425 if Is_Return_Object
(Obj_Id
) then
3427 Func_Id
: constant Entity_Id
:=
3428 Return_Applies_To
(Scope
(Obj_Id
));
3431 if Is_Build_In_Place_Function
(Func_Id
)
3432 and then Needs_BIP_Finalization_Master
(Func_Id
)
3434 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3439 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3440 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3442 -- Temporaries created for the purpose of "exporting" a
3443 -- transient object out of an Expression_With_Actions (EWA)
3444 -- need guards. The following illustrates the usage of such
3447 -- Access_Typ : access [all] Obj_Typ;
3448 -- Temp : Access_Typ := null;
3449 -- <Counter> := ...;
3452 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3453 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3455 -- Temp := Ctrl_Trans'Unchecked_Access;
3458 -- The finalization machinery does not process EWA nodes as
3459 -- this may lead to premature finalization of expressions. Note
3460 -- that Temp is marked as being properly initialized regardless
3461 -- of whether the initialization of Ctrl_Trans succeeded. Since
3462 -- a failed initialization may leave Temp with a value of null,
3463 -- add a guard to handle this case:
3465 -- if Obj /= null then
3466 -- <object finalization statements>
3469 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3470 N_Object_Declaration
3472 Fin_Stmts
:= New_List
(
3473 Make_If_Statement
(Loc
,
3476 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3477 Right_Opnd
=> Make_Null
(Loc
)),
3478 Then_Statements
=> Fin_Stmts
));
3480 -- Return objects use a flag to aid in processing their
3481 -- potential finalization when the enclosing function fails
3482 -- to return properly. Generate:
3485 -- <object finalization statements>
3489 Fin_Stmts
:= New_List
(
3490 Make_If_Statement
(Loc
,
3495 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3497 Then_Statements
=> Fin_Stmts
));
3502 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3504 -- Since the declarations are examined in reverse, the state counter
3505 -- must be decremented in order to keep with the true position of
3508 Counter_Val
:= Counter_Val
- 1;
3509 end Process_Object_Declaration
;
3511 -------------------------------------
3512 -- Process_Tagged_Type_Declaration --
3513 -------------------------------------
3515 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3516 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3517 DT_Ptr
: constant Entity_Id
:=
3518 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3521 -- Ada.Tags.Unregister_Tag (<Typ>P);
3523 Append_To
(Tagged_Type_Stmts
,
3524 Make_Procedure_Call_Statement
(Loc
,
3526 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3527 Parameter_Associations
=> New_List
(
3528 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3529 end Process_Tagged_Type_Declaration
;
3531 -- Start of processing for Build_Finalizer_Helper
3536 -- Do not perform this expansion in SPARK mode because it is not
3539 if GNATprove_Mode
then
3543 -- Step 1: Extract all lists which may contain controlled objects or
3544 -- library-level tagged types.
3546 if For_Package_Spec
then
3547 Decls
:= Visible_Declarations
(Specification
(N
));
3548 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3550 -- Retrieve the package spec id
3552 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3554 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3555 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3558 -- Accept statement, block, entry body, package body, protected body,
3559 -- subprogram body or task body.
3562 Decls
:= Declarations
(N
);
3563 HSS
:= Handled_Statement_Sequence
(N
);
3565 if Present
(HSS
) then
3566 if Present
(Statements
(HSS
)) then
3567 Stmts
:= Statements
(HSS
);
3570 if Present
(At_End_Proc
(HSS
)) then
3571 Prev_At_End
:= At_End_Proc
(HSS
);
3575 -- Retrieve the package spec id for package bodies
3577 if For_Package_Body
then
3578 Spec_Id
:= Corresponding_Spec
(N
);
3582 -- Do not process nested packages since those are handled by the
3583 -- enclosing scope's finalizer. Do not process non-expanded package
3584 -- instantiations since those will be re-analyzed and re-expanded.
3588 (not Is_Library_Level_Entity
(Spec_Id
)
3590 -- Nested packages are library level entities, but do not need to
3591 -- be processed separately.
3593 or else Scope_Depth
(Spec_Id
) /= Uint_1
3594 or else (Is_Generic_Instance
(Spec_Id
)
3595 and then Package_Instantiation
(Spec_Id
) /= N
))
3597 -- Still need to process package body instantiations which may
3598 -- contain objects requiring finalization.
3602 and then Is_Library_Level_Entity
(Spec_Id
)
3603 and then Is_Generic_Instance
(Spec_Id
))
3608 -- Step 2: Object [pre]processing
3612 -- Preprocess the visible declarations now in order to obtain the
3613 -- correct number of controlled object by the time the private
3614 -- declarations are processed.
3616 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3618 -- From all the possible contexts, only package specifications may
3619 -- have private declarations.
3621 if For_Package_Spec
then
3622 Process_Declarations
3623 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3626 -- The current context may lack controlled objects, but require some
3627 -- other form of completion (task termination for instance). In such
3628 -- cases, the finalizer must be created and carry the additional
3631 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3635 -- The preprocessing has determined that the context has controlled
3636 -- objects or library-level tagged types.
3638 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3640 -- Private declarations are processed first in order to preserve
3641 -- possible dependencies between public and private objects.
3643 if For_Package_Spec
then
3644 Process_Declarations
(Priv_Decls
);
3647 Process_Declarations
(Decls
);
3653 -- Preprocess both declarations and statements
3655 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3656 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3658 -- At this point it is known that N has controlled objects. Ensure
3659 -- that N has a declarative list since the finalizer spec will be
3662 if Has_Ctrl_Objs
and then No
(Decls
) then
3663 Set_Declarations
(N
, New_List
);
3664 Decls
:= Declarations
(N
);
3665 Spec_Decls
:= Decls
;
3668 -- The current context may lack controlled objects, but require some
3669 -- other form of completion (task termination for instance). In such
3670 -- cases, the finalizer must be created and carry the additional
3673 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3677 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3678 Process_Declarations
(Stmts
);
3679 Process_Declarations
(Decls
);
3683 -- Step 3: Finalizer creation
3685 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3688 end Build_Finalizer_Helper
;
3690 --------------------------
3691 -- Build_Finalizer_Call --
3692 --------------------------
3694 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3695 Is_Protected_Subp_Body
: constant Boolean :=
3696 Nkind
(N
) = N_Subprogram_Body
3697 and then Is_Protected_Subprogram_Body
(N
);
3698 -- Determine whether N denotes the protected version of a subprogram
3699 -- which belongs to a protected type.
3701 Loc
: constant Source_Ptr
:= Sloc
(N
);
3702 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
3705 -- Do not perform this expansion in SPARK mode because we do not create
3706 -- finalizers in the first place.
3708 if GNATprove_Mode
then
3712 -- If the construct to be cleaned up is a protected subprogram body, the
3713 -- finalizer call needs to be associated with the block that wraps the
3714 -- unprotected version of the subprogram. The following illustrates this
3717 -- procedure Prot_SubpP is
3718 -- procedure finalizer is
3720 -- Service_Entries (Prot_Obj);
3727 -- Prot_SubpN (Prot_Obj);
3733 if Is_Protected_Subp_Body
then
3734 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3737 pragma Assert
(No
(At_End_Proc
(HSS
)));
3738 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3740 -- Attach reference to finalizer to tree, for LLVM use
3742 Set_Parent
(At_End_Proc
(HSS
), HSS
);
3744 Analyze
(At_End_Proc
(HSS
));
3745 Expand_At_End_Handler
(HSS
, Empty
);
3746 end Build_Finalizer_Call
;
3748 ---------------------
3749 -- Build_Finalizer --
3750 ---------------------
3752 procedure Build_Finalizer
3754 Clean_Stmts
: List_Id
;
3755 Mark_Id
: Entity_Id
;
3756 Top_Decls
: List_Id
;
3757 Defer_Abort
: Boolean;
3758 Fin_Id
: out Entity_Id
)
3760 Def_Ent
: constant Entity_Id
:= Unique_Defining_Entity
(N
);
3761 Loc
: constant Source_Ptr
:= Sloc
(N
);
3763 -- Declarations used for the creation of _finalization_controller
3765 Fin_Old_Id
: Entity_Id
:= Empty
;
3766 Fin_Controller_Id
: Entity_Id
:= Empty
;
3767 Fin_Controller_Decls
: List_Id
;
3768 Fin_Controller_Stmts
: List_Id
;
3769 Fin_Controller_Body
: Node_Id
:= Empty
;
3770 Fin_Controller_Spec
: Node_Id
:= Empty
;
3771 Postconditions_Call
: Node_Id
:= Empty
;
3773 -- Defining identifiers for local objects used to store exception info
3775 Raised_Post_Exception_Id
: Entity_Id
:= Empty
;
3776 Raised_Finalization_Exception_Id
: Entity_Id
:= Empty
;
3777 Saved_Exception_Id
: Entity_Id
:= Empty
;
3779 -- Start of processing for Build_Finalizer
3782 -- Create the general finalization routine
3784 Build_Finalizer_Helper
3786 Clean_Stmts
=> Clean_Stmts
,
3788 Top_Decls
=> Top_Decls
,
3789 Defer_Abort
=> Defer_Abort
,
3791 Finalize_Old_Only
=> False);
3793 -- When postconditions are present, expansion gets much more complicated
3794 -- due to both the fact that they must be called after finalization and
3795 -- that finalization of 'Old objects must occur after the postconditions
3798 -- Additionally, exceptions between general finalization and 'Old
3799 -- finalization must be propagated correctly and exceptions which happen
3800 -- during _postconditions need to be saved and reraised after
3801 -- finalization of 'Old objects.
3805 -- Postcond_Enabled := False;
3807 -- procedure _finalization_controller is
3809 -- -- Exception capturing and tracking
3811 -- Saved_Exception : Exception_Occurrence;
3812 -- Raised_Post_Exception : Boolean := False;
3813 -- Raised_Finalization_Exception : Boolean := False;
3815 -- -- Start of processing for _finalization_controller
3818 -- -- Perform general finalization
3824 -- -- Save the exception
3826 -- Raised_Finalization_Exception := True;
3828 -- (Saved_Exception, Get_Current_Excep.all);
3831 -- -- Perform postcondition checks after general finalization, but
3832 -- -- before finalization of 'Old related objects.
3834 -- if not Raised_Finalization_Exception
3835 -- and then Return_Success_For_Postcond
3838 -- -- Re-enable postconditions and check them
3840 -- Postcond_Enabled := True;
3841 -- _postconditions [(Result_Obj_For_Postcond[.all])];
3844 -- -- Save the exception
3846 -- Raised_Post_Exception := True;
3848 -- (Saved_Exception, Get_Current_Excep.all);
3852 -- -- Finally finalize 'Old related objects
3858 -- -- Reraise the previous finalization error if there is
3861 -- if Raised_Finalization_Exception then
3862 -- Reraise_Occurrence (Saved_Exception);
3865 -- -- Otherwise, reraise the current one
3870 -- -- Reraise any saved exception
3872 -- if Raised_Finalization_Exception
3873 -- or else Raised_Post_Exception
3875 -- Reraise_Occurrence (Saved_Exception);
3877 -- end _finalization_controller;
3879 if Nkind
(N
) = N_Subprogram_Body
3880 and then Present
(Postconditions_Proc
(Def_Ent
))
3882 Fin_Controller_Stmts
:= New_List
;
3883 Fin_Controller_Decls
:= New_List
;
3885 -- Build the 'Old finalizer
3887 Build_Finalizer_Helper
3889 Clean_Stmts
=> Empty_List
,
3891 Top_Decls
=> Top_Decls
,
3892 Defer_Abort
=> Defer_Abort
,
3893 Fin_Id
=> Fin_Old_Id
,
3894 Finalize_Old_Only
=> True);
3896 -- Create local declarations for _finalization_controller needed for
3897 -- saving exceptions.
3901 -- Saved_Exception : Exception_Occurrence;
3902 -- Raised_Post_Exception : Boolean := False;
3903 -- Raised_Finalization_Exception : Boolean := False;
3905 Saved_Exception_Id
:= Make_Temporary
(Loc
, 'S');
3906 Raised_Post_Exception_Id
:= Make_Temporary
(Loc
, 'P');
3907 Raised_Finalization_Exception_Id
:= Make_Temporary
(Loc
, 'F');
3909 Append_List_To
(Fin_Controller_Decls
, New_List
(
3910 Make_Object_Declaration
(Loc
,
3911 Defining_Identifier
=> Saved_Exception_Id
,
3912 Object_Definition
=>
3913 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)),
3914 Make_Object_Declaration
(Loc
,
3915 Defining_Identifier
=> Raised_Post_Exception_Id
,
3916 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3917 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)),
3918 Make_Object_Declaration
(Loc
,
3919 Defining_Identifier
=> Raised_Finalization_Exception_Id
,
3920 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3921 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
3923 -- Call _finalizer and save any exceptions which occur
3931 -- Raised_Finalization_Exception := True;
3933 -- (Saved_Exception, Get_Current_Excep.all);
3936 if Present
(Fin_Id
) then
3937 Append_To
(Fin_Controller_Stmts
,
3938 Make_Block_Statement
(Loc
,
3939 Handled_Statement_Sequence
=>
3940 Make_Handled_Sequence_Of_Statements
(Loc
,
3941 Statements
=> New_List
(
3942 Make_Procedure_Call_Statement
(Loc
,
3943 Name
=> New_Occurrence_Of
(Fin_Id
, Loc
))),
3944 Exception_Handlers
=> New_List
(
3945 Make_Exception_Handler
(Loc
,
3946 Exception_Choices
=> New_List
(
3947 Make_Others_Choice
(Loc
)),
3948 Statements
=> New_List
(
3949 Make_Assignment_Statement
(Loc
,
3952 (Raised_Finalization_Exception_Id
, Loc
),
3954 New_Occurrence_Of
(Standard_True
, Loc
)),
3955 Make_Procedure_Call_Statement
(Loc
,
3958 (RTE
(RE_Save_Occurrence
), Loc
),
3959 Parameter_Associations
=> New_List
(
3961 (Saved_Exception_Id
, Loc
),
3962 Make_Explicit_Dereference
(Loc
,
3964 Make_Function_Call
(Loc
,
3966 Make_Explicit_Dereference
(Loc
,
3969 (RTE
(RE_Get_Current_Excep
),
3973 -- Create the call to postconditions based on the kind of the current
3974 -- subprogram, and the type of the Result_Obj_For_Postcond.
3978 -- _postconditions (Result_Obj_For_Postcond[.all]);
3984 if Ekind
(Def_Ent
) = E_Procedure
then
3985 Postconditions_Call
:=
3986 Make_Procedure_Call_Statement
(Loc
,
3989 (Postconditions_Proc
(Def_Ent
), Loc
));
3991 Postconditions_Call
:=
3992 Make_Procedure_Call_Statement
(Loc
,
3995 (Postconditions_Proc
(Def_Ent
), Loc
),
3996 Parameter_Associations
=> New_List
(
3997 (if Is_Elementary_Type
(Etype
(Def_Ent
)) then
3999 (Get_Result_Object_For_Postcond
4002 Make_Explicit_Dereference
(Loc
,
4004 (Get_Result_Object_For_Postcond
4005 (Def_Ent
), Loc
)))));
4008 -- Call _postconditions when no general finalization exceptions have
4009 -- occurred taking care to enable the postconditions and save any
4010 -- exception occurrences.
4014 -- if not Raised_Finalization_Exception
4015 -- and then Return_Success_For_Postcond
4018 -- Postcond_Enabled := True;
4019 -- _postconditions [(Result_Obj_For_Postcond[.all])];
4022 -- Raised_Post_Exception := True;
4024 -- (Saved_Exception, Get_Current_Excep.all);
4028 Append_To
(Fin_Controller_Stmts
,
4029 Make_If_Statement
(Loc
,
4036 (Raised_Finalization_Exception_Id
, Loc
)),
4039 (Get_Return_Success_For_Postcond
(Def_Ent
), Loc
)),
4040 Then_Statements
=> New_List
(
4041 Make_Block_Statement
(Loc
,
4042 Handled_Statement_Sequence
=>
4043 Make_Handled_Sequence_Of_Statements
(Loc
,
4044 Statements
=> New_List
(
4045 Make_Assignment_Statement
(Loc
,
4048 (Get_Postcond_Enabled
(Def_Ent
), Loc
),
4051 (Standard_True
, Loc
)),
4052 Postconditions_Call
),
4053 Exception_Handlers
=> New_List
(
4054 Make_Exception_Handler
(Loc
,
4055 Exception_Choices
=> New_List
(
4056 Make_Others_Choice
(Loc
)),
4057 Statements
=> New_List
(
4058 Make_Assignment_Statement
(Loc
,
4061 (Raised_Post_Exception_Id
, Loc
),
4063 New_Occurrence_Of
(Standard_True
, Loc
)),
4064 Make_Procedure_Call_Statement
(Loc
,
4067 (RTE
(RE_Save_Occurrence
), Loc
),
4068 Parameter_Associations
=> New_List
(
4070 (Saved_Exception_Id
, Loc
),
4071 Make_Explicit_Dereference
(Loc
,
4073 Make_Function_Call
(Loc
,
4075 Make_Explicit_Dereference
(Loc
,
4078 (RTE
(RE_Get_Current_Excep
),
4081 -- Call _finalizer_old and reraise any exception that occurred during
4082 -- initial finalization within the exception handler. Otherwise,
4083 -- propagate the current exception.
4091 -- if Raised_Finalization_Exception then
4092 -- Reraise_Occurrence (Saved_Exception);
4097 if Present
(Fin_Old_Id
) then
4098 Append_To
(Fin_Controller_Stmts
,
4099 Make_Block_Statement
(Loc
,
4100 Handled_Statement_Sequence
=>
4101 Make_Handled_Sequence_Of_Statements
(Loc
,
4102 Statements
=> New_List
(
4103 Make_Procedure_Call_Statement
(Loc
,
4104 Name
=> New_Occurrence_Of
(Fin_Old_Id
, Loc
))),
4105 Exception_Handlers
=> New_List
(
4106 Make_Exception_Handler
(Loc
,
4107 Exception_Choices
=> New_List
(
4108 Make_Others_Choice
(Loc
)),
4109 Statements
=> New_List
(
4110 Make_If_Statement
(Loc
,
4113 (Raised_Finalization_Exception_Id
, Loc
),
4114 Then_Statements
=> New_List
(
4115 Make_Procedure_Call_Statement
(Loc
,
4118 (RTE
(RE_Reraise_Occurrence
), Loc
),
4119 Parameter_Associations
=> New_List
(
4121 (Saved_Exception_Id
, Loc
))))),
4122 Make_Raise_Statement
(Loc
)))))));
4125 -- Once finalization is complete reraise any pending exceptions
4129 -- if Raised_Post_Exception
4130 -- or else Raised_Finalization_Exception
4132 -- Reraise_Occurrence (Saved_Exception);
4135 Append_To
(Fin_Controller_Stmts
,
4136 Make_If_Statement
(Loc
,
4141 (Raised_Post_Exception_Id
, Loc
),
4144 (Raised_Finalization_Exception_Id
, Loc
)),
4145 Then_Statements
=> New_List
(
4146 Make_Procedure_Call_Statement
(Loc
,
4148 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4149 Parameter_Associations
=> New_List
(
4151 (Saved_Exception_Id
, Loc
))))));
4153 -- Make the finalization controller subprogram body and declaration.
4156 -- procedure _finalization_controller;
4158 -- procedure _finalization_controller is
4160 -- [Fin_Controller_Stmts];
4163 Fin_Controller_Id
:=
4164 Make_Defining_Identifier
(Loc
,
4165 Chars
=> New_External_Name
(Name_uFinalization_Controller
));
4167 Fin_Controller_Spec
:=
4168 Make_Subprogram_Declaration
(Loc
,
4170 Make_Procedure_Specification
(Loc
,
4171 Defining_Unit_Name
=> Fin_Controller_Id
));
4173 Fin_Controller_Body
:=
4174 Make_Subprogram_Body
(Loc
,
4176 Make_Procedure_Specification
(Loc
,
4177 Defining_Unit_Name
=>
4178 Make_Defining_Identifier
(Loc
, Chars
(Fin_Controller_Id
))),
4179 Declarations
=> Fin_Controller_Decls
,
4180 Handled_Statement_Sequence
=>
4181 Make_Handled_Sequence_Of_Statements
(Loc
,
4182 Statements
=> Fin_Controller_Stmts
));
4184 -- Disable _postconditions calls which get generated before return
4185 -- statements to delay their evaluation until after finalization.
4187 -- This is done by way of the local Postcond_Enabled object which is
4188 -- initially assigned to True - we then create an assignment within
4189 -- the subprogram's declaration to make it False and assign it back
4190 -- to True before _postconditions is called within
4191 -- _finalization_controller.
4195 -- Postcond_Enable := False;
4197 -- Note that we do not disable early evaluation of postconditions
4198 -- for return types that are unconstrained or have unconstrained
4199 -- elements since the temporary result object could get allocated on
4200 -- the stack and be out of scope at the point where we perform late
4201 -- evaluation of postconditions - leading to uninitialized memory
4204 -- This disabling of early evaluation can lead to incorrect run-time
4205 -- semantics where functions with unconstrained elements will
4206 -- have their corresponding postconditions evaluated before
4207 -- finalization. The proper solution here is to generate a wrapper
4208 -- to capture the result instead of using multiple flags and playing
4209 -- with flags which does not even work in all cases ???
4211 if not Has_Unconstrained_Elements
(Etype
(Def_Ent
))
4212 or else (Is_Array_Type
(Etype
(Def_Ent
))
4213 and then not Is_Constrained
(Etype
(Def_Ent
)))
4215 Append_To
(Top_Decls
,
4216 Make_Assignment_Statement
(Loc
,
4219 (Get_Postcond_Enabled
(Def_Ent
), Loc
),
4222 (Standard_False
, Loc
)));
4225 -- Add the subprogram to the list of declarations an analyze it
4227 Append_To
(Top_Decls
, Fin_Controller_Spec
);
4228 Analyze
(Fin_Controller_Spec
);
4229 Insert_After
(Fin_Controller_Spec
, Fin_Controller_Body
);
4230 Analyze
(Fin_Controller_Body
, Suppress
=> All_Checks
);
4232 -- Return the finalization controller as the result Fin_Id
4234 Fin_Id
:= Fin_Controller_Id
;
4236 end Build_Finalizer
;
4238 ---------------------
4239 -- Build_Late_Proc --
4240 ---------------------
4242 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
4244 for Final_Prim
in Name_Of
'Range loop
4245 if Name_Of
(Final_Prim
) = Nam
then
4248 (Prim
=> Final_Prim
,
4250 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
4253 end Build_Late_Proc
;
4255 -------------------------------
4256 -- Build_Object_Declarations --
4257 -------------------------------
4259 procedure Build_Object_Declarations
4260 (Data
: out Finalization_Exception_Data
;
4263 For_Package
: Boolean := False)
4268 -- This variable captures an unused dummy internal entity, see the
4269 -- comment associated with its use.
4272 pragma Assert
(Decls
/= No_List
);
4274 -- Always set the proper location as it may be needed even when
4275 -- exception propagation is forbidden.
4279 if Restriction_Active
(No_Exception_Propagation
) then
4280 Data
.Abort_Id
:= Empty
;
4282 Data
.Raised_Id
:= Empty
;
4286 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
4288 -- In certain scenarios, finalization can be triggered by an abort. If
4289 -- the finalization itself fails and raises an exception, the resulting
4290 -- Program_Error must be supressed and replaced by an abort signal. In
4291 -- order to detect this scenario, save the state of entry into the
4292 -- finalization code.
4294 -- This is not needed for library-level finalizers as they are called by
4295 -- the environment task and cannot be aborted.
4297 if not For_Package
then
4298 if Abort_Allowed
then
4299 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
4302 -- Abort_Id : constant Boolean := <A_Expr>;
4305 Make_Object_Declaration
(Loc
,
4306 Defining_Identifier
=> Data
.Abort_Id
,
4307 Constant_Present
=> True,
4308 Object_Definition
=>
4309 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4311 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
4313 -- Abort is not required
4316 -- Generate a dummy entity to ensure that the internal symbols are
4317 -- in sync when a unit is compiled with and without aborts.
4319 Dummy
:= Make_Temporary
(Loc
, 'A');
4320 Data
.Abort_Id
:= Empty
;
4323 -- Library-level finalizers
4326 Data
.Abort_Id
:= Empty
;
4329 if Exception_Extra_Info
then
4330 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
4333 -- E_Id : Exception_Occurrence;
4336 Make_Object_Declaration
(Loc
,
4337 Defining_Identifier
=> Data
.E_Id
,
4338 Object_Definition
=>
4339 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
4340 Set_No_Initialization
(Decl
);
4342 Append_To
(Decls
, Decl
);
4349 -- Raised_Id : Boolean := False;
4352 Make_Object_Declaration
(Loc
,
4353 Defining_Identifier
=> Data
.Raised_Id
,
4354 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4355 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
4357 if Debug_Generated_Code
then
4358 Set_Debug_Info_Needed
(Data
.Raised_Id
);
4360 end Build_Object_Declarations
;
4362 ---------------------------
4363 -- Build_Raise_Statement --
4364 ---------------------------
4366 function Build_Raise_Statement
4367 (Data
: Finalization_Exception_Data
) return Node_Id
4373 -- Standard run-time use the specialized routine
4374 -- Raise_From_Controlled_Operation.
4376 if Exception_Extra_Info
4377 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
4380 Make_Procedure_Call_Statement
(Data
.Loc
,
4383 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
4384 Parameter_Associations
=>
4385 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
4387 -- Restricted run-time: exception messages are not supported and hence
4388 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
4393 Make_Raise_Program_Error
(Data
.Loc
,
4394 Reason
=> PE_Finalize_Raised_Exception
);
4399 -- Raised_Id and then not Abort_Id
4403 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
4405 if Present
(Data
.Abort_Id
) then
4406 Expr
:= Make_And_Then
(Data
.Loc
,
4409 Make_Op_Not
(Data
.Loc
,
4410 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
4415 -- if Raised_Id and then not Abort_Id then
4416 -- Raise_From_Controlled_Operation (E_Id);
4418 -- raise Program_Error; -- restricted runtime
4422 Make_If_Statement
(Data
.Loc
,
4424 Then_Statements
=> New_List
(Stmt
));
4425 end Build_Raise_Statement
;
4427 -----------------------------
4428 -- Build_Record_Deep_Procs --
4429 -----------------------------
4431 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
4435 (Prim
=> Initialize_Case
,
4437 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
4439 if not Is_Limited_View
(Typ
) then
4442 (Prim
=> Adjust_Case
,
4444 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
4447 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
4448 -- suppressed since these routine will not be used.
4450 if not Restriction_Active
(No_Finalization
) then
4453 (Prim
=> Finalize_Case
,
4455 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
4457 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
4459 if not CodePeer_Mode
then
4462 (Prim
=> Address_Case
,
4464 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
4467 end Build_Record_Deep_Procs
;
4473 function Cleanup_Array
4476 Typ
: Entity_Id
) return List_Id
4478 Loc
: constant Source_Ptr
:= Sloc
(N
);
4479 Index_List
: constant List_Id
:= New_List
;
4481 function Free_Component
return List_Id
;
4482 -- Generate the code to finalize the task or protected subcomponents
4483 -- of a single component of the array.
4485 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
4486 -- Generate a loop over one dimension of the array
4488 --------------------
4489 -- Free_Component --
4490 --------------------
4492 function Free_Component
return List_Id
is
4493 Stmts
: List_Id
:= New_List
;
4495 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
4498 -- Component type is known to contain tasks or protected objects
4501 Make_Indexed_Component
(Loc
,
4502 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
4503 Expressions
=> Index_List
);
4505 Set_Etype
(Tsk
, C_Typ
);
4507 if Is_Task_Type
(C_Typ
) then
4508 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4510 elsif Is_Simple_Protected_Type
(C_Typ
) then
4511 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4513 elsif Is_Record_Type
(C_Typ
) then
4514 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
4516 elsif Is_Array_Type
(C_Typ
) then
4517 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
4523 ------------------------
4524 -- Free_One_Dimension --
4525 ------------------------
4527 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
4531 if Dim
> Number_Dimensions
(Typ
) then
4532 return Free_Component
;
4534 -- Here we generate the required loop
4537 Index
:= Make_Temporary
(Loc
, 'J');
4538 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
4541 Make_Implicit_Loop_Statement
(N
,
4542 Identifier
=> Empty
,
4544 Make_Iteration_Scheme
(Loc
,
4545 Loop_Parameter_Specification
=>
4546 Make_Loop_Parameter_Specification
(Loc
,
4547 Defining_Identifier
=> Index
,
4548 Discrete_Subtype_Definition
=>
4549 Make_Attribute_Reference
(Loc
,
4550 Prefix
=> Duplicate_Subexpr
(Obj
),
4551 Attribute_Name
=> Name_Range
,
4552 Expressions
=> New_List
(
4553 Make_Integer_Literal
(Loc
, Dim
))))),
4554 Statements
=> Free_One_Dimension
(Dim
+ 1)));
4556 end Free_One_Dimension
;
4558 -- Start of processing for Cleanup_Array
4561 return Free_One_Dimension
(1);
4564 --------------------
4565 -- Cleanup_Record --
4566 --------------------
4568 function Cleanup_Record
4571 Typ
: Entity_Id
) return List_Id
4573 Loc
: constant Source_Ptr
:= Sloc
(N
);
4574 Stmts
: constant List_Id
:= New_List
;
4575 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
4581 if Has_Discriminants
(U_Typ
)
4582 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
4583 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
4586 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
4588 -- For now, do not attempt to free a component that may appear in a
4589 -- variant, and instead issue a warning. Doing this "properly" would
4590 -- require building a case statement and would be quite a mess. Note
4591 -- that the RM only requires that free "work" for the case of a task
4592 -- access value, so already we go way beyond this in that we deal
4593 -- with the array case and non-discriminated record cases.
4596 ("task/protected object in variant record will not be freed??", N
);
4597 return New_List
(Make_Null_Statement
(Loc
));
4600 Comp
:= First_Component
(U_Typ
);
4601 while Present
(Comp
) loop
4602 if Chars
(Comp
) /= Name_uParent
4603 and then (Has_Task
(Etype
(Comp
))
4604 or else Has_Simple_Protected_Object
(Etype
(Comp
)))
4607 Make_Selected_Component
(Loc
,
4608 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
4609 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
4610 Set_Etype
(Tsk
, Etype
(Comp
));
4612 if Is_Task_Type
(Etype
(Comp
)) then
4613 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4615 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
4616 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4618 elsif Is_Record_Type
(Etype
(Comp
)) then
4620 -- Recurse, by generating the prefix of the argument to the
4621 -- eventual cleanup call.
4623 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
4625 elsif Is_Array_Type
(Etype
(Comp
)) then
4626 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
4630 Next_Component
(Comp
);
4636 ------------------------------
4637 -- Cleanup_Protected_Object --
4638 ------------------------------
4640 function Cleanup_Protected_Object
4642 Ref
: Node_Id
) return Node_Id
4644 Loc
: constant Source_Ptr
:= Sloc
(N
);
4647 -- For restricted run-time libraries (Ravenscar), tasks are
4648 -- non-terminating, and protected objects can only appear at library
4649 -- level, so we do not want finalization of protected objects.
4651 if Restricted_Profile
then
4656 Make_Procedure_Call_Statement
(Loc
,
4658 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4659 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4661 end Cleanup_Protected_Object
;
4667 function Cleanup_Task
4669 Ref
: Node_Id
) return Node_Id
4671 Loc
: constant Source_Ptr
:= Sloc
(N
);
4674 -- For restricted run-time libraries (Ravenscar), tasks are
4675 -- non-terminating and they can only appear at library level,
4676 -- so we do not want finalization of task objects.
4678 if Restricted_Profile
then
4683 Make_Procedure_Call_Statement
(Loc
,
4685 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4686 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4690 --------------------------------------
4691 -- Check_Unnesting_Elaboration_Code --
4692 --------------------------------------
4694 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4695 Loc
: constant Source_Ptr
:= Sloc
(N
);
4696 Block_Elab_Proc
: Entity_Id
:= Empty
;
4698 procedure Set_Block_Elab_Proc
;
4699 -- Create a defining identifier for a procedure that will replace
4700 -- a block with nested subprograms (unless it has already been created,
4701 -- in which case this is a no-op).
4703 procedure Set_Block_Elab_Proc
is
4705 if No
(Block_Elab_Proc
) then
4706 Block_Elab_Proc
:= Make_Temporary
(Loc
, 'I');
4708 end Set_Block_Elab_Proc
;
4710 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4711 -- Find entities in the elaboration code of a library package body that
4712 -- contain or represent a subprogram body. A body can appear within a
4713 -- block or a loop or can appear by itself if generated for an object
4714 -- declaration that involves controlled actions. The first such entity
4715 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4716 -- that will be used to reset the scopes of all entities that become
4717 -- local to the new elaboration procedure. This is needed for subsequent
4718 -- unnesting actions, which depend on proper setting of the Scope links
4719 -- to determine the nesting level of each subprogram.
4721 -----------------------
4722 -- Find_Local_Scope --
4723 -----------------------
4725 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4732 while Present
(Stat
) loop
4733 case Nkind
(Stat
) is
4734 when N_Block_Statement
=>
4735 if Present
(Identifier
(Stat
)) then
4736 Id
:= Entity
(Identifier
(Stat
));
4738 -- The Scope of this block needs to be reset to the new
4739 -- procedure if the block contains nested subprograms.
4741 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4742 Set_Block_Elab_Proc
;
4743 Set_Scope
(Id
, Block_Elab_Proc
);
4747 when N_Loop_Statement
=>
4748 Id
:= Entity
(Identifier
(Stat
));
4750 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4751 if Scope
(Id
) = Current_Scope
then
4752 Set_Block_Elab_Proc
;
4753 Set_Scope
(Id
, Block_Elab_Proc
);
4757 -- We traverse the loop's statements as well, which may
4758 -- include other block (etc.) statements that need to have
4759 -- their Scope set to Block_Elab_Proc. (Is this really the
4760 -- case, or do such nested blocks refer to the loop scope
4761 -- rather than the loop's enclosing scope???.)
4763 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4765 when N_If_Statement
=>
4766 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4767 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4769 Node
:= First
(Elsif_Parts
(Stat
));
4770 while Present
(Node
) loop
4771 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4775 when N_Case_Statement
=>
4776 Node
:= First
(Alternatives
(Stat
));
4777 while Present
(Node
) loop
4778 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4782 -- Reset the Scope of a subprogram occurring at the top level
4784 when N_Subprogram_Body
=>
4785 Id
:= Defining_Entity
(Stat
);
4787 Set_Block_Elab_Proc
;
4788 Set_Scope
(Id
, Block_Elab_Proc
);
4796 end Reset_Scopes_To_Block_Elab_Proc
;
4800 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4801 Elab_Body
: Node_Id
;
4802 Elab_Call
: Node_Id
;
4804 -- Start of processing for Check_Unnesting_Elaboration_Code
4807 if Present
(H_Seq
) then
4808 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4810 -- There may be subprograms declared in the exception handlers
4811 -- of the current body.
4813 if Present
(Exception_Handlers
(H_Seq
)) then
4815 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4817 while Present
(Handler
) loop
4818 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4825 if Present
(Block_Elab_Proc
) then
4827 Make_Subprogram_Body
(Loc
,
4829 Make_Procedure_Specification
(Loc
,
4830 Defining_Unit_Name
=> Block_Elab_Proc
),
4831 Declarations
=> New_List
,
4832 Handled_Statement_Sequence
=>
4833 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4836 Make_Procedure_Call_Statement
(Loc
,
4837 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4839 Append_To
(Declarations
(N
), Elab_Body
);
4840 Analyze
(Elab_Body
);
4841 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4843 Set_Handled_Statement_Sequence
(N
,
4844 Make_Handled_Sequence_Of_Statements
(Loc
,
4845 Statements
=> New_List
(Elab_Call
)));
4847 Analyze
(Elab_Call
);
4849 -- Could we reset the scopes of entities associated with the new
4850 -- procedure here via a loop over entities rather than doing it in
4851 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4854 end Check_Unnesting_Elaboration_Code
;
4856 ---------------------------------------
4857 -- Check_Unnesting_In_Decls_Or_Stmts --
4858 ---------------------------------------
4860 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4861 Decl_Or_Stmt
: Node_Id
;
4864 if Unnest_Subprogram_Mode
4865 and then Present
(Decls_Or_Stmts
)
4867 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4868 while Present
(Decl_Or_Stmt
) loop
4869 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4870 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4872 Unnest_Block
(Decl_Or_Stmt
);
4874 -- If-statements may contain subprogram bodies at the outer level
4875 -- of their statement lists, and the subprograms may make up-level
4876 -- references (such as to objects declared in the same statement
4877 -- list). Unlike block and loop cases, however, we don't have an
4878 -- entity on which to test the Contains_Subprogram flag, so
4879 -- Unnest_If_Statement must traverse the statement lists to
4880 -- determine whether there are nested subprograms present.
4882 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4883 Unnest_If_Statement
(Decl_Or_Stmt
);
4885 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4887 Id
: constant Entity_Id
:=
4888 Entity
(Identifier
(Decl_Or_Stmt
));
4891 -- When a top-level loop within declarations of a library
4892 -- package spec or body contains nested subprograms, we wrap
4893 -- it in a procedure to handle possible up-level references
4894 -- to entities associated with the loop (such as loop
4897 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4898 Unnest_Loop
(Decl_Or_Stmt
);
4902 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4903 and then not Modify_Tree_For_C
4905 Check_Unnesting_In_Decls_Or_Stmts
4906 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4907 Check_Unnesting_In_Decls_Or_Stmts
4908 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4910 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4911 and then not Modify_Tree_For_C
4913 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4914 if Present
(Statements
4915 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4917 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4918 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4919 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4923 Next
(Decl_Or_Stmt
);
4926 end Check_Unnesting_In_Decls_Or_Stmts
;
4928 ---------------------------------
4929 -- Check_Unnesting_In_Handlers --
4930 ---------------------------------
4932 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4933 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4936 if Present
(Stmt_Seq
)
4937 and then Present
(Exception_Handlers
(Stmt_Seq
))
4940 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4942 while Present
(Handler
) loop
4943 if Present
(Statements
(Handler
)) then
4944 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4951 end Check_Unnesting_In_Handlers
;
4953 ------------------------------
4954 -- Check_Visibly_Controlled --
4955 ------------------------------
4957 procedure Check_Visibly_Controlled
4958 (Prim
: Final_Primitives
;
4960 E
: in out Entity_Id
;
4961 Cref
: in out Node_Id
)
4963 Parent_Type
: Entity_Id
;
4967 if Is_Derived_Type
(Typ
)
4968 and then Comes_From_Source
(E
)
4969 and then not Present
(Overridden_Operation
(E
))
4971 -- We know that the explicit operation on the type does not override
4972 -- the inherited operation of the parent, and that the derivation
4973 -- is from a private type that is not visibly controlled.
4975 Parent_Type
:= Etype
(Typ
);
4976 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4978 if Present
(Op
) then
4981 -- Wrap the object to be initialized into the proper
4982 -- unchecked conversion, to be compatible with the operation
4985 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4986 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4988 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4992 end Check_Visibly_Controlled
;
4994 --------------------------
4995 -- Contains_Subprogram --
4996 --------------------------
4998 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
5002 E
:= First_Entity
(Blk
);
5004 while Present
(E
) loop
5005 if Is_Subprogram
(E
) then
5008 elsif Ekind
(E
) in E_Block | E_Loop
5009 and then Contains_Subprogram
(E
)
5018 end Contains_Subprogram
;
5024 function Convert_View
5027 Ind
: Pos
:= 1) return Node_Id
5029 Fent
: Entity_Id
:= First_Entity
(Proc
);
5034 for J
in 2 .. Ind
loop
5038 Ftyp
:= Etype
(Fent
);
5040 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
5041 Atyp
:= Entity
(Subtype_Mark
(Arg
));
5043 Atyp
:= Etype
(Arg
);
5046 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
5047 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
5050 and then Present
(Atyp
)
5051 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
5052 and then Base_Type
(Underlying_Type
(Atyp
)) =
5053 Base_Type
(Underlying_Type
(Ftyp
))
5055 return Unchecked_Convert_To
(Ftyp
, Arg
);
5057 -- If the argument is already a conversion, as generated by
5058 -- Make_Init_Call, set the target type to the type of the formal
5059 -- directly, to avoid spurious typing problems.
5061 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
5062 and then not Is_Class_Wide_Type
(Atyp
)
5064 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
5065 Set_Etype
(Arg
, Ftyp
);
5068 -- Otherwise, introduce a conversion when the designated object
5069 -- has a type derived from the formal of the controlled routine.
5071 elsif Is_Private_Type
(Ftyp
)
5072 and then Present
(Atyp
)
5073 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
5075 return Unchecked_Convert_To
(Ftyp
, Arg
);
5082 -------------------------------
5083 -- Establish_Transient_Scope --
5084 -------------------------------
5086 -- This procedure is called each time a transient block has to be inserted
5087 -- that is to say for each call to a function with unconstrained or tagged
5088 -- result. It creates a new scope on the scope stack in order to enclose
5089 -- all transient variables generated.
5091 procedure Establish_Transient_Scope
5093 Manage_Sec_Stack
: Boolean)
5095 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
5096 -- Determine whether arbitrary Id denotes a package or subprogram [body]
5098 function Find_Enclosing_Transient_Scope
return Entity_Id
;
5099 -- Examine the scope stack looking for the nearest enclosing transient
5100 -- scope within the innermost enclosing package or subprogram. Return
5101 -- Empty if no such scope exists.
5103 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
5104 -- Locate a suitable context for arbitrary node N which may need to be
5105 -- serviced by a transient scope. Return Empty if no suitable context
5108 procedure Delegate_Sec_Stack_Management
;
5109 -- Move the management of the secondary stack to the nearest enclosing
5112 procedure Create_Transient_Scope
(Context
: Node_Id
);
5113 -- Place a new scope on the scope stack in order to service construct
5114 -- Context. Context is the node found by Find_Transient_Context. The
5115 -- new scope may also manage the secondary stack.
5117 ----------------------------
5118 -- Create_Transient_Scope --
5119 ----------------------------
5121 procedure Create_Transient_Scope
(Context
: Node_Id
) is
5122 Loc
: constant Source_Ptr
:= Sloc
(N
);
5124 Iter_Loop
: Entity_Id
;
5125 Trans_Scop
: constant Entity_Id
:=
5126 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
5129 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
5131 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
5134 Push_Scope
(Trans_Scop
);
5135 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
5136 Set_Scope_Is_Transient
;
5138 -- The transient scope must also manage the secondary stack
5140 if Manage_Sec_Stack
then
5141 Set_Uses_Sec_Stack
(Trans_Scop
);
5142 Check_Restriction
(No_Secondary_Stack
, N
);
5144 -- The expansion of iterator loops generates references to objects
5145 -- in order to extract elements from a container:
5147 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
5148 -- Obj : <object type> renames Ref.all.Element.all;
5150 -- These references are controlled and returned on the secondary
5151 -- stack. A new reference is created at each iteration of the loop
5152 -- and as a result it must be finalized and the space occupied by
5153 -- it on the secondary stack reclaimed at the end of the current
5156 -- When the context that requires a transient scope is a call to
5157 -- routine Reference, the node to be wrapped is the source object:
5159 -- for Obj of Container loop
5161 -- Routine Wrap_Transient_Declaration however does not generate
5162 -- a physical block as wrapping a declaration will kill it too
5163 -- early. To handle this peculiar case, mark the related iterator
5164 -- loop as requiring the secondary stack. This signals the
5165 -- finalization machinery to manage the secondary stack (see
5166 -- routine Process_Statements_For_Controlled_Objects).
5168 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
5170 if Present
(Iter_Loop
) then
5171 Set_Uses_Sec_Stack
(Iter_Loop
);
5175 if Debug_Flag_W
then
5176 Write_Str
(" <Transient>");
5179 end Create_Transient_Scope
;
5181 -----------------------------------
5182 -- Delegate_Sec_Stack_Management --
5183 -----------------------------------
5185 procedure Delegate_Sec_Stack_Management
is
5187 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
5189 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
5191 -- Prevent the search from going too far or within the scope
5192 -- space of another unit.
5194 if Scope
.Entity
= Standard_Standard
then
5197 -- No transient scope should be encountered during the
5198 -- traversal because Establish_Transient_Scope should have
5199 -- already handled this case.
5201 elsif Scope
.Is_Transient
then
5202 raise Program_Error
;
5204 -- The construct that requires secondary stack management is
5205 -- always enclosed by a package or subprogram scope.
5207 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
5208 Set_Uses_Sec_Stack
(Scope
.Entity
);
5209 Check_Restriction
(No_Secondary_Stack
, N
);
5216 -- At this point no suitable scope was found. This should never occur
5217 -- because a construct is always enclosed by a compilation unit which
5220 pragma Assert
(False);
5221 end Delegate_Sec_Stack_Management
;
5223 ------------------------------------
5224 -- Find_Enclosing_Transient_Scope --
5225 ------------------------------------
5227 function Find_Enclosing_Transient_Scope
return Entity_Id
is
5229 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
5231 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
5233 -- Prevent the search from going too far or within the scope
5234 -- space of another unit.
5236 if Scope
.Entity
= Standard_Standard
5237 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
5241 elsif Scope
.Is_Transient
then
5242 return Scope
.Entity
;
5248 end Find_Enclosing_Transient_Scope
;
5250 ----------------------------
5251 -- Find_Transient_Context --
5252 ----------------------------
5254 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
5255 Curr
: Node_Id
:= N
;
5256 Prev
: Node_Id
:= Empty
;
5259 while Present
(Curr
) loop
5260 case Nkind
(Curr
) is
5264 -- Declarations act as a boundary for a transient scope even if
5265 -- they are not wrapped, see Wrap_Transient_Declaration.
5267 when N_Object_Declaration
5268 | N_Object_Renaming_Declaration
5269 | N_Subtype_Declaration
5275 -- Statements and statement-like constructs act as a boundary
5276 -- for a transient scope.
5278 when N_Accept_Alternative
5279 | N_Attribute_Definition_Clause
5281 | N_Case_Statement_Alternative
5283 | N_Delay_Alternative
5284 | N_Delay_Until_Statement
5285 | N_Delay_Relative_Statement
5286 | N_Discriminant_Association
5288 | N_Entry_Body_Formal_Part
5291 | N_Iteration_Scheme
5292 | N_Terminate_Alternative
5294 pragma Assert
(Present
(Prev
));
5297 when N_Assignment_Statement
=>
5300 when N_Entry_Call_Statement
5301 | N_Procedure_Call_Statement
5303 -- When an entry or procedure call acts as the alternative
5304 -- of a conditional or timed entry call, the proper context
5305 -- is that of the alternative.
5307 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
5308 and then Nkind
(Parent
(Parent
(Curr
))) in
5309 N_Conditional_Entry_Call | N_Timed_Entry_Call
5311 return Parent
(Parent
(Curr
));
5313 -- General case for entry or procedure calls
5321 -- Pragma Check is not a valid transient context in
5322 -- GNATprove mode because the pragma must remain unchanged.
5325 and then Get_Pragma_Id
(Curr
) = Pragma_Check
5329 -- General case for pragmas
5335 when N_Raise_Statement
=>
5338 when N_Simple_Return_Statement
=>
5340 -- A return statement is not a valid transient context when
5341 -- the function itself requires transient scope management
5342 -- because the result will be reclaimed too early.
5344 if Requires_Transient_Scope
(Etype
5345 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
5349 -- General case for return statements
5357 when N_Attribute_Reference
=>
5358 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
5362 -- An Ada 2012 iterator specification is not a valid context
5363 -- because Analyze_Iterator_Specification already employs
5364 -- special processing for it.
5366 when N_Iterator_Specification
=>
5369 when N_Loop_Parameter_Specification
=>
5371 -- An iteration scheme is not a valid context because
5372 -- routine Analyze_Iteration_Scheme already employs
5373 -- special processing.
5375 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
5378 return Parent
(Curr
);
5383 -- The following nodes represent "dummy contexts" which do not
5384 -- need to be wrapped.
5386 when N_Component_Declaration
5387 | N_Discriminant_Specification
5388 | N_Parameter_Specification
5392 -- If the traversal leaves a scope without having been able to
5393 -- find a construct to wrap, something is going wrong, but this
5394 -- can happen in error situations that are not detected yet
5395 -- (such as a dynamic string in a pragma Export).
5397 when N_Block_Statement
5400 | N_Package_Declaration
5414 Curr
:= Parent
(Curr
);
5418 end Find_Transient_Context
;
5420 ------------------------------
5421 -- Is_Package_Or_Subprogram --
5422 ------------------------------
5424 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
5426 return Ekind
(Id
) in E_Entry
5431 | E_Subprogram_Body
;
5432 end Is_Package_Or_Subprogram
;
5436 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
5439 -- Start of processing for Establish_Transient_Scope
5442 -- Do not create a new transient scope if there is already an enclosing
5443 -- transient scope within the innermost enclosing package or subprogram.
5445 if Present
(Trans_Id
) then
5447 -- If the transient scope was requested for purposes of managing the
5448 -- secondary stack, then the existing scope must perform this task.
5450 if Manage_Sec_Stack
then
5451 Set_Uses_Sec_Stack
(Trans_Id
);
5457 -- Find the construct that must be serviced by a new transient scope, if
5460 Context
:= Find_Transient_Context
(N
);
5462 if Present
(Context
) then
5463 if Nkind
(Context
) = N_Assignment_Statement
then
5465 -- An assignment statement with suppressed controlled semantics
5466 -- does not need a transient scope because finalization is not
5467 -- desirable at this point. Note that No_Ctrl_Actions is also
5468 -- set for non-controlled assignments to suppress dispatching
5471 if No_Ctrl_Actions
(Context
)
5472 and then Needs_Finalization
(Etype
(Name
(Context
)))
5474 -- When a controlled component is initialized by a function
5475 -- call, the result on the secondary stack is always assigned
5476 -- to the component. Signal the nearest suitable scope that it
5477 -- is safe to manage the secondary stack.
5479 if Manage_Sec_Stack
and then Within_Init_Proc
then
5480 Delegate_Sec_Stack_Management
;
5483 -- Otherwise the assignment is a normal transient context and thus
5484 -- requires a transient scope.
5487 Create_Transient_Scope
(Context
);
5493 Create_Transient_Scope
(Context
);
5496 end Establish_Transient_Scope
;
5498 ----------------------------
5499 -- Expand_Cleanup_Actions --
5500 ----------------------------
5502 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
5504 (Nkind
(N
) in N_Block_Statement
5508 | N_Extended_Return_Statement
);
5510 Scop
: constant Entity_Id
:= Current_Scope
;
5512 Is_Asynchronous_Call
: constant Boolean :=
5513 Nkind
(N
) = N_Block_Statement
5514 and then Is_Asynchronous_Call_Block
(N
);
5515 Is_Master
: constant Boolean :=
5516 Nkind
(N
) /= N_Extended_Return_Statement
5517 and then Nkind
(N
) /= N_Entry_Body
5518 and then Is_Task_Master
(N
);
5519 Is_Protected_Subp_Body
: constant Boolean :=
5520 Nkind
(N
) = N_Subprogram_Body
5521 and then Is_Protected_Subprogram_Body
(N
);
5522 Is_Task_Allocation
: constant Boolean :=
5523 Nkind
(N
) = N_Block_Statement
5524 and then Is_Task_Allocation_Block
(N
);
5525 Is_Task_Body
: constant Boolean :=
5526 Nkind
(Original_Node
(N
)) = N_Task_Body
;
5528 -- We mark the secondary stack if it is used in this construct, and
5529 -- we're not returning a function result on the secondary stack, except
5530 -- that a build-in-place function that might or might not return on the
5531 -- secondary stack always needs a mark. A run-time test is required in
5532 -- the case where the build-in-place function has a BIP_Alloc extra
5533 -- parameter (see Create_Finalizer).
5535 Needs_Sec_Stack_Mark
: constant Boolean :=
5536 (Uses_Sec_Stack
(Scop
)
5538 not Sec_Stack_Needed_For_Return
(Scop
))
5540 (Is_Build_In_Place_Function
(Scop
)
5541 and then Needs_BIP_Alloc_Form
(Scop
));
5543 Needs_Custom_Cleanup
: constant Boolean :=
5544 Nkind
(N
) = N_Block_Statement
5545 and then Present
(Cleanup_Actions
(N
));
5547 Has_Postcondition
: constant Boolean :=
5548 Nkind
(N
) = N_Subprogram_Body
5550 (Postconditions_Proc
5551 (Unique_Defining_Entity
(N
)));
5553 Actions_Required
: constant Boolean :=
5554 Requires_Cleanup_Actions
(N
, True)
5555 or else Is_Asynchronous_Call
5557 or else Is_Protected_Subp_Body
5558 or else Is_Task_Allocation
5559 or else Is_Task_Body
5560 or else Needs_Sec_Stack_Mark
5561 or else Needs_Custom_Cleanup
;
5563 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
5567 procedure Wrap_HSS_In_Block
;
5568 -- Move HSS inside a new block along with the original exception
5569 -- handlers. Make the newly generated block the sole statement of HSS.
5571 -----------------------
5572 -- Wrap_HSS_In_Block --
5573 -----------------------
5575 procedure Wrap_HSS_In_Block
is
5576 Block
: constant Node_Id
:=
5577 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
5578 Block_Id
: constant Entity_Id
:=
5579 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
5580 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
5581 -- Preserve end label to provide proper cross-reference information
5584 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
5585 Set_Etype
(Block_Id
, Standard_Void_Type
);
5586 Set_Block_Node
(Block_Id
, Identifier
(Block
));
5588 -- Signal the finalization machinery that this particular block
5589 -- contains the original context.
5591 Set_Is_Finalization_Wrapper
(Block
);
5593 HSS
:= Make_Handled_Sequence_Of_Statements
(Loc
,
5594 Statements
=> New_List
(Block
),
5595 End_Label
=> End_Lab
);
5596 Set_First_Real_Statement
(HSS
, Block
);
5597 Set_Handled_Statement_Sequence
(N
, HSS
);
5599 if Nkind
(N
) = N_Subprogram_Body
then
5600 Set_Has_Nested_Block_With_Handler
(Scop
);
5602 end Wrap_HSS_In_Block
;
5604 -- Start of processing for Expand_Cleanup_Actions
5607 -- The current construct does not need any form of servicing
5609 if not Actions_Required
then
5612 -- If the current node is a rewritten task body and the descriptors have
5613 -- not been delayed (due to some nested instantiations), do not generate
5614 -- redundant cleanup actions.
5617 and then Nkind
(N
) = N_Subprogram_Body
5618 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
5623 -- If an extended return statement contains something like
5627 -- where F is a build-in-place function call returning a controlled
5628 -- type, then a temporary object will be implicitly declared as part
5629 -- of the statement list, and this will need cleanup. In such cases,
5632 -- return Result : T := ... do
5633 -- <statements> -- possibly with handlers
5638 -- return Result : T := ... do
5639 -- declare -- no declarations
5641 -- <statements> -- possibly with handlers
5642 -- end; -- no handlers
5645 -- So Expand_Cleanup_Actions will end up being called recursively on the
5648 if Nkind
(N
) = N_Extended_Return_Statement
then
5650 Block
: constant Node_Id
:=
5651 Make_Block_Statement
(Sloc
(N
),
5652 Declarations
=> Empty_List
,
5653 Handled_Statement_Sequence
=>
5654 Handled_Statement_Sequence
(N
));
5656 Set_Handled_Statement_Sequence
(N
,
5657 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
5658 Statements
=> New_List
(Block
)));
5663 -- Analysis of the block did all the work
5668 if Needs_Custom_Cleanup
then
5669 Cln
:= Cleanup_Actions
(N
);
5675 Decls
: List_Id
:= Declarations
(N
);
5677 Mark
: Entity_Id
:= Empty
;
5678 New_Decls
: List_Id
;
5681 -- If we are generating expanded code for debugging purposes, use the
5682 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5683 -- be updated subsequently to reference the proper line in .dg files.
5684 -- If we are not debugging generated code, use No_Location instead,
5685 -- so that no debug information is generated for the cleanup code.
5686 -- This makes the behavior of the NEXT command in GDB monotonic, and
5687 -- makes the placement of breakpoints more accurate.
5689 if Debug_Generated_Code
then
5695 -- A task activation call has already been built for a task
5696 -- allocation block.
5698 if not Is_Task_Allocation
then
5699 Build_Task_Activation_Call
(N
);
5703 Establish_Task_Master
(N
);
5706 New_Decls
:= New_List
;
5708 -- If secondary stack is in use, generate:
5710 -- Mnn : constant Mark_Id := SS_Mark;
5712 if Needs_Sec_Stack_Mark
then
5713 Mark
:= Make_Temporary
(Loc
, 'M');
5715 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
5716 Set_Uses_Sec_Stack
(Scop
, False);
5719 -- If exception handlers are present in a non-subprogram
5720 -- construct, wrap the sequence of statements in a block.
5721 -- Otherwise, code can be moved so that the wrong handlers
5722 -- apply. It is important not to do this for function bodies,
5723 -- because otherwise transient finalizable objects created
5724 -- by a return statement get finalized too late. It is harmless
5725 -- not to do this for procedures.
5727 if Present
(Exception_Handlers
(HSS
))
5728 and then Nkind
(N
) /= N_Subprogram_Body
5732 -- Ensure that the First_Real_Statement field is set
5734 elsif No
(First_Real_Statement
(HSS
)) then
5735 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
5738 -- Do not move the Activation_Chain declaration in the context of
5739 -- task allocation blocks. Task allocation blocks use _chain in their
5740 -- cleanup handlers and gigi complains if it is declared in the
5741 -- sequence of statements of the scope that declares the handler.
5743 if Is_Task_Allocation
then
5745 Chain_Decl
: constant N_Object_Declaration_Id
:=
5746 Parent
(Activation_Chain_Entity
(N
));
5747 pragma Assert
(List_Containing
(Chain_Decl
) = Decls
);
5749 Remove
(Chain_Decl
);
5750 Prepend_To
(New_Decls
, Chain_Decl
);
5754 -- Move the _postconditions subprogram declaration and its associated
5755 -- objects into the declarations section so that it is callable
5756 -- within _postconditions.
5758 if Has_Postcondition
then
5761 Prev_Decl
: Node_Id
;
5765 Prev
(Subprogram_Body
5766 (Postconditions_Proc
(Current_Subprogram
)));
5767 while Present
(Decl
) loop
5768 Prev_Decl
:= Prev
(Decl
);
5771 Prepend_To
(New_Decls
, Decl
);
5773 exit when Nkind
(Decl
) = N_Subprogram_Declaration
5774 and then Chars
(Corresponding_Body
(Decl
))
5775 = Name_uPostconditions
;
5782 -- Ensure the presence of a declaration list in order to successfully
5783 -- append all original statements to it.
5786 Set_Declarations
(N
, New_List
);
5787 Decls
:= Declarations
(N
);
5790 -- Move the declarations into the sequence of statements in order to
5791 -- have them protected by the At_End handler. It may seem weird to
5792 -- put declarations in the sequence of statement but in fact nothing
5793 -- forbids that at the tree level.
5795 Append_List_To
(Decls
, Statements
(HSS
));
5796 Set_Statements
(HSS
, Decls
);
5798 -- Reset the Sloc of the handled statement sequence to properly
5799 -- reflect the new initial "statement" in the sequence.
5801 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
5803 -- The declarations of finalizer spec and auxiliary variables replace
5804 -- the old declarations that have been moved inward.
5806 Set_Declarations
(N
, New_Decls
);
5807 Analyze_Declarations
(New_Decls
);
5809 -- Generate finalization calls for all controlled objects appearing
5810 -- in the statements of N. Add context specific cleanup for various
5815 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5817 Top_Decls
=> New_Decls
,
5818 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5822 if Present
(Fin_Id
) then
5823 Build_Finalizer_Call
(N
, Fin_Id
);
5826 end Expand_Cleanup_Actions
;
5828 ---------------------------
5829 -- Expand_N_Package_Body --
5830 ---------------------------
5832 -- Add call to Activate_Tasks if body is an activator (actual processing
5833 -- is in chapter 9).
5835 -- Generate subprogram descriptor for elaboration routine
5837 -- Encode entity names in package body
5839 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5840 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5844 -- This is done only for non-generic packages
5846 if Ekind
(Spec_Id
) = E_Package
then
5847 -- Build dispatch tables of library-level tagged types for bodies
5848 -- that are not compilation units (see Analyze_Compilation_Unit),
5849 -- except for instances because they have no N_Compilation_Unit.
5851 if Tagged_Type_Expansion
5852 and then Is_Library_Level_Entity
(Spec_Id
)
5853 and then (not Is_Compilation_Unit
(Spec_Id
)
5854 or else Is_Generic_Instance
(Spec_Id
))
5856 Build_Static_Dispatch_Tables
(N
);
5859 Push_Scope
(Spec_Id
);
5861 Expand_CUDA_Package
(N
);
5863 Build_Task_Activation_Call
(N
);
5865 -- Verify the run-time semantics of pragma Initial_Condition at the
5866 -- end of the body statements.
5868 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5870 -- If this is a library-level package and unnesting is enabled,
5871 -- check for the presence of blocks with nested subprograms occurring
5872 -- in elaboration code, and generate procedures to encapsulate the
5873 -- blocks in case the nested subprograms make up-level references.
5875 if Unnest_Subprogram_Mode
5877 Is_Library_Level_Entity
(Current_Scope
)
5879 Check_Unnesting_Elaboration_Code
(N
);
5880 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5881 Check_Unnesting_In_Handlers
(N
);
5887 Set_Elaboration_Flag
(N
, Spec_Id
);
5888 Set_In_Package_Body
(Spec_Id
, False);
5890 -- Set to encode entity names in package body before gigi is called
5892 Qualify_Entity_Names
(N
);
5894 if Ekind
(Spec_Id
) /= E_Generic_Package
then
5897 Clean_Stmts
=> No_List
,
5899 Top_Decls
=> No_List
,
5900 Defer_Abort
=> False,
5903 if Present
(Fin_Id
) then
5905 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
5908 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
5909 Body_Ent
:= Defining_Identifier
(Body_Ent
);
5912 Set_Finalizer
(Body_Ent
, Fin_Id
);
5916 end Expand_N_Package_Body
;
5918 ----------------------------------
5919 -- Expand_N_Package_Declaration --
5920 ----------------------------------
5922 -- Add call to Activate_Tasks if there are tasks declared and the package
5923 -- has no body. Note that in Ada 83 this may result in premature activation
5924 -- of some tasks, given that we cannot tell whether a body will eventually
5927 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5928 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5929 Spec
: constant Node_Id
:= Specification
(N
);
5933 No_Body
: Boolean := False;
5934 -- True in the case of a package declaration that is a compilation
5935 -- unit and for which no associated body will be compiled in this
5939 -- Case of a package declaration other than a compilation unit
5941 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5944 -- Case of a compilation unit that does not require a body
5946 elsif not Body_Required
(Parent
(N
))
5947 and then not Unit_Requires_Body
(Id
)
5951 -- Special case of generating calling stubs for a remote call interface
5952 -- package: even though the package declaration requires one, the body
5953 -- won't be processed in this compilation (so any stubs for RACWs
5954 -- declared in the package must be generated here, along with the spec).
5956 elsif Parent
(N
) = Cunit
(Main_Unit
)
5957 and then Is_Remote_Call_Interface
(Id
)
5958 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5963 -- For a nested instance, delay processing until freeze point
5965 if Has_Delayed_Freeze
(Id
)
5966 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5971 -- For a package declaration that implies no associated body, generate
5972 -- task activation call and RACW supporting bodies now (since we won't
5973 -- have a specific separate compilation unit for that).
5978 -- Generate RACW subprogram bodies
5980 if Has_RACW
(Id
) then
5981 Decls
:= Private_Declarations
(Spec
);
5984 Decls
:= Visible_Declarations
(Spec
);
5989 Set_Visible_Declarations
(Spec
, Decls
);
5992 Append_RACW_Bodies
(Decls
, Id
);
5993 Analyze_List
(Decls
);
5996 -- Generate task activation call as last step of elaboration
5998 if Present
(Activation_Chain_Entity
(N
)) then
5999 Build_Task_Activation_Call
(N
);
6002 -- Verify the run-time semantics of pragma Initial_Condition at the
6003 -- end of the private declarations when the package lacks a body.
6005 Expand_Pragma_Initial_Condition
(Id
, N
);
6010 -- Build dispatch tables of library-level tagged types for instances
6011 -- that are not compilation units (see Analyze_Compilation_Unit).
6013 if Tagged_Type_Expansion
6014 and then Is_Library_Level_Entity
(Id
)
6015 and then Is_Generic_Instance
(Id
)
6016 and then not Is_Compilation_Unit
(Id
)
6018 Build_Static_Dispatch_Tables
(N
);
6021 -- Note: it is not necessary to worry about generating a subprogram
6022 -- descriptor, since the only way to get exception handlers into a
6023 -- package spec is to include instantiations, and that would cause
6024 -- generation of subprogram descriptors to be delayed in any case.
6026 -- Set to encode entity names in package spec before gigi is called
6028 Qualify_Entity_Names
(N
);
6030 if Ekind
(Id
) /= E_Generic_Package
then
6033 Clean_Stmts
=> No_List
,
6035 Top_Decls
=> No_List
,
6036 Defer_Abort
=> False,
6039 Set_Finalizer
(Id
, Fin_Id
);
6042 -- If this is a library-level package and unnesting is enabled,
6043 -- check for the presence of blocks with nested subprograms occurring
6044 -- in elaboration code, and generate procedures to encapsulate the
6045 -- blocks in case the nested subprograms make up-level references.
6047 if Unnest_Subprogram_Mode
6048 and then Is_Library_Level_Entity
(Current_Scope
)
6050 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
6051 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
6053 end Expand_N_Package_Declaration
;
6055 ---------------------------------
6056 -- Has_Simple_Protected_Object --
6057 ---------------------------------
6059 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
6061 if Has_Task
(T
) then
6064 elsif Is_Simple_Protected_Type
(T
) then
6067 elsif Is_Array_Type
(T
) then
6068 return Has_Simple_Protected_Object
(Component_Type
(T
));
6070 elsif Is_Record_Type
(T
) then
6075 Comp
:= First_Component
(T
);
6076 while Present
(Comp
) loop
6077 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
6081 Next_Component
(Comp
);
6090 end Has_Simple_Protected_Object
;
6092 ------------------------------------
6093 -- Insert_Actions_In_Scope_Around --
6094 ------------------------------------
6096 procedure Insert_Actions_In_Scope_Around
6099 Manage_SS
: Boolean)
6101 Act_Before
: constant List_Id
:=
6102 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
6103 Act_After
: constant List_Id
:=
6104 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
6105 Act_Cleanup
: constant List_Id
:=
6106 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
6107 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
6108 -- Last), but this was incorrect as Process_Transients_In_Scope may
6109 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
6111 procedure Process_Transients_In_Scope
6112 (First_Object
: Node_Id
;
6113 Last_Object
: Node_Id
;
6114 Related_Node
: Node_Id
);
6115 -- Find all transient objects in the list First_Object .. Last_Object
6116 -- and generate finalization actions for them. Related_Node denotes the
6117 -- node which created all transient objects.
6119 ---------------------------------
6120 -- Process_Transients_In_Scope --
6121 ---------------------------------
6123 procedure Process_Transients_In_Scope
6124 (First_Object
: Node_Id
;
6125 Last_Object
: Node_Id
;
6126 Related_Node
: Node_Id
)
6128 Must_Hook
: Boolean;
6129 -- Flag denoting whether the context requires transient object
6130 -- export to the outer finalizer.
6132 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
6133 -- Return Abandon if arbitrary node denotes a subprogram call
6135 function Has_Subprogram_Call
is
6136 new Traverse_Func
(Is_Subprogram_Call
);
6138 procedure Process_Transient_In_Scope
6139 (Obj_Decl
: Node_Id
;
6140 Blk_Data
: Finalization_Exception_Data
;
6141 Blk_Stmts
: List_Id
);
6142 -- Generate finalization actions for a single transient object
6143 -- denoted by object declaration Obj_Decl. Blk_Data is the
6144 -- exception data of the enclosing block. Blk_Stmts denotes the
6145 -- statements of the enclosing block.
6147 ------------------------
6148 -- Is_Subprogram_Call --
6149 ------------------------
6151 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
6153 -- A regular procedure or function call
6155 if Nkind
(N
) in N_Subprogram_Call
then
6160 -- Heavy expansion may relocate function calls outside the related
6161 -- node. Inspect the original node to detect the initial placement
6164 elsif Is_Rewrite_Substitution
(N
) then
6165 return Has_Subprogram_Call
(Original_Node
(N
));
6167 -- Generalized indexing always involves a function call
6169 elsif Nkind
(N
) = N_Indexed_Component
6170 and then Present
(Generalized_Indexing
(N
))
6179 end Is_Subprogram_Call
;
6181 --------------------------------
6182 -- Process_Transient_In_Scope --
6183 --------------------------------
6185 procedure Process_Transient_In_Scope
6186 (Obj_Decl
: Node_Id
;
6187 Blk_Data
: Finalization_Exception_Data
;
6188 Blk_Stmts
: List_Id
)
6190 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
6191 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
6193 Fin_Stmts
: List_Id
;
6194 Hook_Assign
: Node_Id
;
6195 Hook_Clear
: Node_Id
;
6196 Hook_Decl
: Node_Id
;
6197 Hook_Insert
: Node_Id
;
6201 -- Mark the transient object as successfully processed to avoid
6202 -- double finalization.
6204 Set_Is_Finalized_Transient
(Obj_Id
);
6206 -- Construct all the pieces necessary to hook and finalize the
6207 -- transient object.
6209 Build_Transient_Object_Statements
6210 (Obj_Decl
=> Obj_Decl
,
6211 Fin_Call
=> Fin_Call
,
6212 Hook_Assign
=> Hook_Assign
,
6213 Hook_Clear
=> Hook_Clear
,
6214 Hook_Decl
=> Hook_Decl
,
6215 Ptr_Decl
=> Ptr_Decl
);
6217 -- The context contains at least one subprogram call which may
6218 -- raise an exception. This scenario employs "hooking" to pass
6219 -- transient objects to the enclosing finalizer in case of an
6224 -- Add the access type which provides a reference to the
6225 -- transient object. Generate:
6227 -- type Ptr_Typ is access all Desig_Typ;
6229 Insert_Action
(Obj_Decl
, Ptr_Decl
);
6231 -- Add the temporary which acts as a hook to the transient
6232 -- object. Generate:
6234 -- Hook : Ptr_Typ := null;
6236 Insert_Action
(Obj_Decl
, Hook_Decl
);
6238 -- When the transient object is initialized by an aggregate,
6239 -- the hook must capture the object after the last aggregate
6240 -- assignment takes place. Only then is the object considered
6241 -- fully initialized. Generate:
6243 -- Hook := Ptr_Typ (Obj_Id);
6245 -- Hook := Obj_Id'Unrestricted_Access;
6247 -- Similarly if we have a build in place call: we must
6248 -- initialize Hook only after the call has happened, otherwise
6249 -- Obj_Id will not be initialized yet.
6251 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
6252 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
6253 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
6254 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
6255 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
6257 Hook_Insert
:= Obj_Decl
;
6260 -- Otherwise the hook seizes the related object immediately
6263 Hook_Insert
:= Obj_Decl
;
6266 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
6269 -- When exception propagation is enabled wrap the hook clear
6270 -- statement and the finalization call into a block to catch
6271 -- potential exceptions raised during finalization. Generate:
6275 -- [Deep_]Finalize (Obj_Ref);
6279 -- if not Raised then
6282 -- (Enn, Get_Current_Excep.all.all);
6286 if Exceptions_OK
then
6287 Fin_Stmts
:= New_List
;
6290 Append_To
(Fin_Stmts
, Hook_Clear
);
6293 Append_To
(Fin_Stmts
, Fin_Call
);
6295 Prepend_To
(Blk_Stmts
,
6296 Make_Block_Statement
(Loc
,
6297 Handled_Statement_Sequence
=>
6298 Make_Handled_Sequence_Of_Statements
(Loc
,
6299 Statements
=> Fin_Stmts
,
6300 Exception_Handlers
=> New_List
(
6301 Build_Exception_Handler
(Blk_Data
)))));
6303 -- Otherwise generate:
6306 -- [Deep_]Finalize (Obj_Ref);
6308 -- Note that the statements are inserted in reverse order to
6309 -- achieve the desired final order outlined above.
6312 Prepend_To
(Blk_Stmts
, Fin_Call
);
6315 Prepend_To
(Blk_Stmts
, Hook_Clear
);
6318 end Process_Transient_In_Scope
;
6322 Built
: Boolean := False;
6323 Blk_Data
: Finalization_Exception_Data
;
6324 Blk_Decl
: Node_Id
:= Empty
;
6325 Blk_Decls
: List_Id
:= No_List
;
6327 Blk_Stmts
: List_Id
:= No_List
;
6328 Loc
: Source_Ptr
:= No_Location
;
6331 -- Start of processing for Process_Transients_In_Scope
6334 -- The expansion performed by this routine is as follows:
6336 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
6337 -- Hook_1 : Ptr_Typ_1 := null;
6338 -- Ctrl_Trans_Obj_1 : ...;
6339 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
6341 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
6342 -- Hook_N : Ptr_Typ_N := null;
6343 -- Ctrl_Trans_Obj_N : ...;
6344 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
6347 -- Abrt : constant Boolean := ...;
6348 -- Ex : Exception_Occurrence;
6349 -- Raised : Boolean := False;
6356 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
6360 -- if not Raised then
6362 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6367 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
6371 -- if not Raised then
6373 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6378 -- if Raised and not Abrt then
6379 -- Raise_From_Controlled_Operation (Ex);
6383 -- Recognize a scenario where the transient context is an object
6384 -- declaration initialized by a build-in-place function call:
6386 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
6388 -- The rough expansion of the above is:
6390 -- Temp : ... := Ctrl_Func_Call;
6392 -- Res : ... := BIP_Func_Call (..., Obj, ...);
6394 -- The finalization of any transient object must happen after the
6395 -- build-in-place function call is executed.
6397 if Nkind
(N
) = N_Object_Declaration
6398 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
6401 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
6403 -- Search the context for at least one subprogram call. If found, the
6404 -- machinery exports all transient objects to the enclosing finalizer
6405 -- due to the possibility of abnormal call termination.
6408 Must_Hook
:= Has_Subprogram_Call
(N
) = Abandon
;
6409 Blk_Ins
:= Last_Object
;
6413 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
6416 -- Examine all objects in the list First_Object .. Last_Object
6418 Obj_Decl
:= First_Object
;
6419 while Present
(Obj_Decl
) loop
6420 if Nkind
(Obj_Decl
) = N_Object_Declaration
6421 and then Analyzed
(Obj_Decl
)
6422 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
6424 -- Do not process the node to be wrapped since it will be
6425 -- handled by the enclosing finalizer.
6427 and then Obj_Decl
/= Related_Node
6429 Loc
:= Sloc
(Obj_Decl
);
6431 -- Before generating the cleanup code for the first transient
6432 -- object, create a wrapper block which houses all hook clear
6433 -- statements and finalization calls. This wrapper is needed by
6438 Blk_Stmts
:= New_List
;
6441 -- Abrt : constant Boolean := ...;
6442 -- Ex : Exception_Occurrence;
6443 -- Raised : Boolean := False;
6445 if Exceptions_OK
then
6446 Blk_Decls
:= New_List
;
6447 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
6451 Make_Block_Statement
(Loc
,
6452 Declarations
=> Blk_Decls
,
6453 Handled_Statement_Sequence
=>
6454 Make_Handled_Sequence_Of_Statements
(Loc
,
6455 Statements
=> Blk_Stmts
));
6458 -- Construct all necessary circuitry to hook and finalize a
6459 -- single transient object.
6461 pragma Assert
(Present
(Blk_Stmts
));
6462 Process_Transient_In_Scope
6463 (Obj_Decl
=> Obj_Decl
,
6464 Blk_Data
=> Blk_Data
,
6465 Blk_Stmts
=> Blk_Stmts
);
6468 -- Terminate the scan after the last object has been processed to
6469 -- avoid touching unrelated code.
6471 if Obj_Decl
= Last_Object
then
6478 -- Complete the decoration of the enclosing finalization block and
6479 -- insert it into the tree.
6481 if Present
(Blk_Decl
) then
6483 pragma Assert
(Present
(Blk_Stmts
));
6484 pragma Assert
(Loc
/= No_Location
);
6486 -- Note that this Abort_Undefer does not require a extra block or
6487 -- an AT_END handler because each finalization exception is caught
6488 -- in its own corresponding finalization block. As a result, the
6489 -- call to Abort_Defer always takes place.
6491 if Abort_Allowed
then
6492 Prepend_To
(Blk_Stmts
,
6493 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
6495 Append_To
(Blk_Stmts
,
6496 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
6500 -- if Raised and then not Abrt then
6501 -- Raise_From_Controlled_Operation (Ex);
6504 if Exceptions_OK
then
6505 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
6508 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
6510 end Process_Transients_In_Scope
;
6514 Loc
: constant Source_Ptr
:= Sloc
(N
);
6515 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
6516 First_Obj
: Node_Id
;
6518 Mark_Id
: Entity_Id
;
6521 -- Start of processing for Insert_Actions_In_Scope_Around
6524 -- Nothing to do if the scope does not manage the secondary stack or
6525 -- does not contain meaningful actions for insertion.
6528 and then No
(Act_Before
)
6529 and then No
(Act_After
)
6530 and then No
(Act_Cleanup
)
6535 -- If the node to be wrapped is the trigger of an asynchronous select,
6536 -- it is not part of a statement list. The actions must be inserted
6537 -- before the select itself, which is part of some list of statements.
6538 -- Note that the triggering alternative includes the triggering
6539 -- statement and an optional statement list. If the node to be
6540 -- wrapped is part of that list, the normal insertion applies.
6542 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
6543 and then not Is_List_Member
(Node_To_Wrap
)
6545 Target
:= Parent
(Parent
(Node_To_Wrap
));
6550 First_Obj
:= Target
;
6553 -- Add all actions associated with a transient scope into the main tree.
6554 -- There are several scenarios here:
6556 -- +--- Before ----+ +----- After ---+
6557 -- 1) First_Obj ....... Target ........ Last_Obj
6559 -- 2) First_Obj ....... Target
6561 -- 3) Target ........ Last_Obj
6563 -- Flag declarations are inserted before the first object
6565 if Present
(Act_Before
) then
6566 First_Obj
:= First
(Act_Before
);
6567 Insert_List_Before
(Target
, Act_Before
);
6570 -- Finalization calls are inserted after the last object
6572 if Present
(Act_After
) then
6573 Last_Obj
:= Last
(Act_After
);
6574 Insert_List_After
(Target
, Act_After
);
6577 -- Mark and release the secondary stack when the context warrants it
6580 Mark_Id
:= Make_Temporary
(Loc
, 'M');
6583 -- Mnn : constant Mark_Id := SS_Mark;
6585 Insert_Before_And_Analyze
6586 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
6589 -- SS_Release (Mnn);
6591 Insert_After_And_Analyze
6592 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
6595 -- Check for transient objects associated with Target and generate the
6596 -- appropriate finalization actions for them.
6598 Process_Transients_In_Scope
6599 (First_Object
=> First_Obj
,
6600 Last_Object
=> Last_Obj
,
6601 Related_Node
=> Target
);
6603 -- Reset the action lists
6606 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
6608 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
6612 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
6614 end Insert_Actions_In_Scope_Around
;
6616 ------------------------------
6617 -- Is_Simple_Protected_Type --
6618 ------------------------------
6620 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
6623 Is_Protected_Type
(T
)
6624 and then not Uses_Lock_Free
(T
)
6625 and then not Has_Entries
(T
)
6626 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
6627 end Is_Simple_Protected_Type
;
6629 -----------------------
6630 -- Make_Adjust_Call --
6631 -----------------------
6633 function Make_Adjust_Call
6636 Skip_Self
: Boolean := False) return Node_Id
6638 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
6639 Adj_Id
: Entity_Id
:= Empty
;
6646 -- Recover the proper type which contains Deep_Adjust
6648 if Is_Class_Wide_Type
(Typ
) then
6649 Utyp
:= Root_Type
(Typ
);
6654 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
6655 Set_Assignment_OK
(Ref
);
6657 -- Deal with untagged derivation of private views
6659 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
6660 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6661 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6662 Set_Assignment_OK
(Ref
);
6665 -- When dealing with the completion of a private type, use the base
6668 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
6669 pragma Assert
(Is_Private_Type
(Typ
));
6671 Utyp
:= Base_Type
(Utyp
);
6672 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6675 -- The underlying type may not be present due to a missing full view. In
6676 -- this case freezing did not take place and there is no [Deep_]Adjust
6677 -- primitive to call.
6682 elsif Skip_Self
then
6683 if Has_Controlled_Component
(Utyp
) then
6684 if Is_Tagged_Type
(Utyp
) then
6685 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6687 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6691 -- Class-wide types, interfaces and types with controlled components
6693 elsif Is_Class_Wide_Type
(Typ
)
6694 or else Is_Interface
(Typ
)
6695 or else Has_Controlled_Component
(Utyp
)
6697 if Is_Tagged_Type
(Utyp
) then
6698 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6700 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6703 -- Derivations from [Limited_]Controlled
6705 elsif Is_Controlled
(Utyp
) then
6706 if Has_Controlled_Component
(Utyp
) then
6707 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6709 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
6714 elsif Is_Tagged_Type
(Utyp
) then
6715 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6718 raise Program_Error
;
6721 if Present
(Adj_Id
) then
6723 -- If the object is unanalyzed, set its expected type for use in
6724 -- Convert_View in case an additional conversion is needed.
6727 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
6729 Set_Etype
(Ref
, Typ
);
6732 -- The object reference may need another conversion depending on the
6733 -- type of the formal and that of the actual.
6735 if not Is_Class_Wide_Type
(Typ
) then
6736 Ref
:= Convert_View
(Adj_Id
, Ref
);
6743 Skip_Self
=> Skip_Self
);
6747 end Make_Adjust_Call
;
6755 Proc_Id
: Entity_Id
;
6757 Skip_Self
: Boolean := False) return Node_Id
6759 Params
: constant List_Id
:= New_List
(Param
);
6762 -- Do not apply the controlled action to the object itself by signaling
6763 -- the related routine to avoid self.
6766 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6770 Make_Procedure_Call_Statement
(Loc
,
6771 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6772 Parameter_Associations
=> Params
);
6775 --------------------------
6776 -- Make_Deep_Array_Body --
6777 --------------------------
6779 function Make_Deep_Array_Body
6780 (Prim
: Final_Primitives
;
6781 Typ
: Entity_Id
) return List_Id
6783 function Build_Adjust_Or_Finalize_Statements
6784 (Typ
: Entity_Id
) return List_Id
;
6785 -- Create the statements necessary to adjust or finalize an array of
6786 -- controlled elements. Generate:
6789 -- Abort : constant Boolean := Triggered_By_Abort;
6791 -- Abort : constant Boolean := False; -- no abort
6793 -- E : Exception_Occurrence;
6794 -- Raised : Boolean := False;
6797 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6798 -- ^-- in the finalization case
6800 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6802 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6806 -- if not Raised then
6808 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6815 -- if Raised and then not Abort then
6816 -- Raise_From_Controlled_Operation (E);
6820 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6821 -- Create the statements necessary to initialize an array of controlled
6822 -- elements. Include a mechanism to carry out partial finalization if an
6823 -- exception occurs. Generate:
6826 -- Counter : Integer := 0;
6829 -- for J1 in V'Range (1) loop
6831 -- for JN in V'Range (N) loop
6833 -- [Deep_]Initialize (V (J1, ..., JN));
6835 -- Counter := Counter + 1;
6840 -- Abort : constant Boolean := Triggered_By_Abort;
6842 -- Abort : constant Boolean := False; -- no abort
6843 -- E : Exception_Occurrence;
6844 -- Raised : Boolean := False;
6851 -- V'Length (N) - Counter;
6853 -- for F1 in reverse V'Range (1) loop
6855 -- for FN in reverse V'Range (N) loop
6856 -- if Counter > 0 then
6857 -- Counter := Counter - 1;
6860 -- [Deep_]Finalize (V (F1, ..., FN));
6864 -- if not Raised then
6866 -- Save_Occurrence (E,
6867 -- Get_Current_Excep.all.all);
6876 -- if Raised and then not Abort then
6877 -- Raise_From_Controlled_Operation (E);
6886 function New_References_To
6888 Loc
: Source_Ptr
) return List_Id
;
6889 -- Given a list of defining identifiers, return a list of references to
6890 -- the original identifiers, in the same order as they appear.
6892 -----------------------------------------
6893 -- Build_Adjust_Or_Finalize_Statements --
6894 -----------------------------------------
6896 function Build_Adjust_Or_Finalize_Statements
6897 (Typ
: Entity_Id
) return List_Id
6899 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6900 Index_List
: constant List_Id
:= New_List
;
6901 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6902 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6904 procedure Build_Indexes
;
6905 -- Generate the indexes used in the dimension loops
6911 procedure Build_Indexes
is
6913 -- Generate the following identifiers:
6914 -- Jnn - for initialization
6916 for Dim
in 1 .. Num_Dims
loop
6917 Append_To
(Index_List
,
6918 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6924 Final_Decls
: List_Id
:= No_List
;
6925 Final_Data
: Finalization_Exception_Data
;
6929 Core_Loop
: Node_Id
;
6932 Loop_Id
: Entity_Id
;
6935 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6938 Final_Decls
:= New_List
;
6941 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6944 Make_Indexed_Component
(Loc
,
6945 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6946 Expressions
=> New_References_To
(Index_List
, Loc
));
6947 Set_Etype
(Comp_Ref
, Comp_Typ
);
6950 -- [Deep_]Adjust (V (J1, ..., JN))
6952 if Prim
= Adjust_Case
then
6953 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6956 -- [Deep_]Finalize (V (J1, ..., JN))
6958 else pragma Assert
(Prim
= Finalize_Case
);
6959 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6962 if Present
(Call
) then
6964 -- Generate the block which houses the adjust or finalize call:
6967 -- <adjust or finalize call>
6971 -- if not Raised then
6973 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6977 if Exceptions_OK
then
6979 Make_Block_Statement
(Loc
,
6980 Handled_Statement_Sequence
=>
6981 Make_Handled_Sequence_Of_Statements
(Loc
,
6982 Statements
=> New_List
(Call
),
6983 Exception_Handlers
=> New_List
(
6984 Build_Exception_Handler
(Final_Data
))));
6989 -- Generate the dimension loops starting from the innermost one
6991 -- for Jnn in [reverse] V'Range (Dim) loop
6995 J
:= Last
(Index_List
);
6997 while Present
(J
) and then Dim
> 0 loop
7003 Make_Loop_Statement
(Loc
,
7005 Make_Iteration_Scheme
(Loc
,
7006 Loop_Parameter_Specification
=>
7007 Make_Loop_Parameter_Specification
(Loc
,
7008 Defining_Identifier
=> Loop_Id
,
7009 Discrete_Subtype_Definition
=>
7010 Make_Attribute_Reference
(Loc
,
7011 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7012 Attribute_Name
=> Name_Range
,
7013 Expressions
=> New_List
(
7014 Make_Integer_Literal
(Loc
, Dim
))),
7017 Prim
= Finalize_Case
)),
7019 Statements
=> New_List
(Core_Loop
),
7020 End_Label
=> Empty
);
7025 -- Generate the block which contains the core loop, declarations
7026 -- of the abort flag, the exception occurrence, the raised flag
7027 -- and the conditional raise:
7030 -- Abort : constant Boolean := Triggered_By_Abort;
7032 -- Abort : constant Boolean := False; -- no abort
7034 -- E : Exception_Occurrence;
7035 -- Raised : Boolean := False;
7040 -- if Raised and then not Abort then
7041 -- Raise_From_Controlled_Operation (E);
7045 Stmts
:= New_List
(Core_Loop
);
7047 if Exceptions_OK
then
7048 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
7052 Make_Block_Statement
(Loc
,
7053 Declarations
=> Final_Decls
,
7054 Handled_Statement_Sequence
=>
7055 Make_Handled_Sequence_Of_Statements
(Loc
,
7056 Statements
=> Stmts
));
7058 -- Otherwise previous errors or a missing full view may prevent the
7059 -- proper freezing of the component type. If this is the case, there
7060 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
7063 Block
:= Make_Null_Statement
(Loc
);
7066 return New_List
(Block
);
7067 end Build_Adjust_Or_Finalize_Statements
;
7069 ---------------------------------
7070 -- Build_Initialize_Statements --
7071 ---------------------------------
7073 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
7074 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
7075 Final_List
: constant List_Id
:= New_List
;
7076 Index_List
: constant List_Id
:= New_List
;
7077 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7078 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
7080 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
7081 -- Generate the following assignment:
7082 -- Counter := V'Length (1) *
7084 -- V'Length (N) - Counter;
7086 -- Counter_Id denotes the entity of the counter.
7088 function Build_Finalization_Call
return Node_Id
;
7089 -- Generate a deep finalization call for an array element
7091 procedure Build_Indexes
;
7092 -- Generate the initialization and finalization indexes used in the
7095 function Build_Initialization_Call
return Node_Id
;
7096 -- Generate a deep initialization call for an array element
7098 ----------------------
7099 -- Build_Assignment --
7100 ----------------------
7102 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
7107 -- Start from the first dimension and generate:
7112 Make_Attribute_Reference
(Loc
,
7113 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7114 Attribute_Name
=> Name_Length
,
7115 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
7117 -- Process the rest of the dimensions, generate:
7118 -- Expr * V'Length (N)
7121 while Dim
<= Num_Dims
loop
7123 Make_Op_Multiply
(Loc
,
7126 Make_Attribute_Reference
(Loc
,
7127 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7128 Attribute_Name
=> Name_Length
,
7129 Expressions
=> New_List
(
7130 Make_Integer_Literal
(Loc
, Dim
))));
7136 -- Counter := Expr - Counter;
7139 Make_Assignment_Statement
(Loc
,
7140 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7142 Make_Op_Subtract
(Loc
,
7144 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
7145 end Build_Assignment
;
7147 -----------------------------
7148 -- Build_Finalization_Call --
7149 -----------------------------
7151 function Build_Finalization_Call
return Node_Id
is
7152 Comp_Ref
: constant Node_Id
:=
7153 Make_Indexed_Component
(Loc
,
7154 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7155 Expressions
=> New_References_To
(Final_List
, Loc
));
7158 Set_Etype
(Comp_Ref
, Comp_Typ
);
7161 -- [Deep_]Finalize (V);
7163 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
7164 end Build_Finalization_Call
;
7170 procedure Build_Indexes
is
7172 -- Generate the following identifiers:
7173 -- Jnn - for initialization
7174 -- Fnn - for finalization
7176 for Dim
in 1 .. Num_Dims
loop
7177 Append_To
(Index_List
,
7178 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
7180 Append_To
(Final_List
,
7181 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
7185 -------------------------------
7186 -- Build_Initialization_Call --
7187 -------------------------------
7189 function Build_Initialization_Call
return Node_Id
is
7190 Comp_Ref
: constant Node_Id
:=
7191 Make_Indexed_Component
(Loc
,
7192 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7193 Expressions
=> New_References_To
(Index_List
, Loc
));
7196 Set_Etype
(Comp_Ref
, Comp_Typ
);
7199 -- [Deep_]Initialize (V (J1, ..., JN));
7201 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
7202 end Build_Initialization_Call
;
7206 Counter_Id
: Entity_Id
;
7210 Final_Block
: Node_Id
;
7211 Final_Data
: Finalization_Exception_Data
;
7212 Final_Decls
: List_Id
:= No_List
;
7213 Final_Loop
: Node_Id
;
7214 Init_Block
: Node_Id
;
7215 Init_Call
: Node_Id
;
7216 Init_Loop
: Node_Id
;
7221 -- Start of processing for Build_Initialize_Statements
7224 Counter_Id
:= Make_Temporary
(Loc
, 'C');
7225 Final_Decls
:= New_List
;
7228 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
7230 -- Generate the block which houses the finalization call, the index
7231 -- guard and the handler which triggers Program_Error later on.
7233 -- if Counter > 0 then
7234 -- Counter := Counter - 1;
7237 -- [Deep_]Finalize (V (F1, ..., FN));
7240 -- if not Raised then
7242 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7247 Fin_Stmt
:= Build_Finalization_Call
;
7249 if Present
(Fin_Stmt
) then
7250 if Exceptions_OK
then
7252 Make_Block_Statement
(Loc
,
7253 Handled_Statement_Sequence
=>
7254 Make_Handled_Sequence_Of_Statements
(Loc
,
7255 Statements
=> New_List
(Fin_Stmt
),
7256 Exception_Handlers
=> New_List
(
7257 Build_Exception_Handler
(Final_Data
))));
7260 -- This is the core of the loop, the dimension iterators are added
7261 -- one by one in reverse.
7264 Make_If_Statement
(Loc
,
7267 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7268 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
7270 Then_Statements
=> New_List
(
7271 Make_Assignment_Statement
(Loc
,
7272 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7274 Make_Op_Subtract
(Loc
,
7275 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7276 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
7278 Else_Statements
=> New_List
(Fin_Stmt
));
7280 -- Generate all finalization loops starting from the innermost
7283 -- for Fnn in reverse V'Range (Dim) loop
7287 F
:= Last
(Final_List
);
7289 while Present
(F
) and then Dim
> 0 loop
7295 Make_Loop_Statement
(Loc
,
7297 Make_Iteration_Scheme
(Loc
,
7298 Loop_Parameter_Specification
=>
7299 Make_Loop_Parameter_Specification
(Loc
,
7300 Defining_Identifier
=> Loop_Id
,
7301 Discrete_Subtype_Definition
=>
7302 Make_Attribute_Reference
(Loc
,
7303 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7304 Attribute_Name
=> Name_Range
,
7305 Expressions
=> New_List
(
7306 Make_Integer_Literal
(Loc
, Dim
))),
7308 Reverse_Present
=> True)),
7310 Statements
=> New_List
(Final_Loop
),
7311 End_Label
=> Empty
);
7316 -- Generate the block which contains the finalization loops, the
7317 -- declarations of the abort flag, the exception occurrence, the
7318 -- raised flag and the conditional raise.
7321 -- Abort : constant Boolean := Triggered_By_Abort;
7323 -- Abort : constant Boolean := False; -- no abort
7325 -- E : Exception_Occurrence;
7326 -- Raised : Boolean := False;
7332 -- V'Length (N) - Counter;
7336 -- if Raised and then not Abort then
7337 -- Raise_From_Controlled_Operation (E);
7343 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
7345 if Exceptions_OK
then
7346 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
7347 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
7351 Make_Block_Statement
(Loc
,
7352 Declarations
=> Final_Decls
,
7353 Handled_Statement_Sequence
=>
7354 Make_Handled_Sequence_Of_Statements
(Loc
,
7355 Statements
=> Stmts
));
7357 -- Otherwise previous errors or a missing full view may prevent the
7358 -- proper freezing of the component type. If this is the case, there
7359 -- is no [Deep_]Finalize primitive to call.
7362 Final_Block
:= Make_Null_Statement
(Loc
);
7365 -- Generate the block which contains the initialization call and
7366 -- the partial finalization code.
7369 -- [Deep_]Initialize (V (J1, ..., JN));
7371 -- Counter := Counter + 1;
7375 -- <finalization code>
7378 Init_Call
:= Build_Initialization_Call
;
7380 -- Only create finalization block if there is a nontrivial call
7381 -- to initialization or a Default_Initial_Condition check to be
7384 if (Present
(Init_Call
)
7385 and then Nkind
(Init_Call
) /= N_Null_Statement
)
7388 and then not GNATprove_Mode
7389 and then Present
(DIC_Procedure
(Comp_Typ
))
7390 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
7393 Init_Stmts
: constant List_Id
:= New_List
;
7396 if Present
(Init_Call
) then
7397 Append_To
(Init_Stmts
, Init_Call
);
7400 if Has_DIC
(Comp_Typ
)
7401 and then Present
(DIC_Procedure
(Comp_Typ
))
7405 Build_DIC_Call
(Loc
,
7406 Make_Indexed_Component
(Loc
,
7407 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7408 Expressions
=> New_References_To
(Index_List
, Loc
)),
7413 Make_Block_Statement
(Loc
,
7414 Handled_Statement_Sequence
=>
7415 Make_Handled_Sequence_Of_Statements
(Loc
,
7416 Statements
=> Init_Stmts
,
7417 Exception_Handlers
=> New_List
(
7418 Make_Exception_Handler
(Loc
,
7419 Exception_Choices
=> New_List
(
7420 Make_Others_Choice
(Loc
)),
7421 Statements
=> New_List
(Final_Block
)))));
7424 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
7425 Make_Assignment_Statement
(Loc
,
7426 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7429 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
7430 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
7432 -- Generate all initialization loops starting from the innermost
7435 -- for Jnn in V'Range (Dim) loop
7439 J
:= Last
(Index_List
);
7441 while Present
(J
) and then Dim
> 0 loop
7447 Make_Loop_Statement
(Loc
,
7449 Make_Iteration_Scheme
(Loc
,
7450 Loop_Parameter_Specification
=>
7451 Make_Loop_Parameter_Specification
(Loc
,
7452 Defining_Identifier
=> Loop_Id
,
7453 Discrete_Subtype_Definition
=>
7454 Make_Attribute_Reference
(Loc
,
7455 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7456 Attribute_Name
=> Name_Range
,
7457 Expressions
=> New_List
(
7458 Make_Integer_Literal
(Loc
, Dim
))))),
7460 Statements
=> New_List
(Init_Loop
),
7461 End_Label
=> Empty
);
7466 -- Generate the block which contains the counter variable and the
7467 -- initialization loops.
7470 -- Counter : Integer := 0;
7476 Make_Block_Statement
(Loc
,
7477 Declarations
=> New_List
(
7478 Make_Object_Declaration
(Loc
,
7479 Defining_Identifier
=> Counter_Id
,
7480 Object_Definition
=>
7481 New_Occurrence_Of
(Standard_Integer
, Loc
),
7482 Expression
=> Make_Integer_Literal
(Loc
, 0))),
7484 Handled_Statement_Sequence
=>
7485 Make_Handled_Sequence_Of_Statements
(Loc
,
7486 Statements
=> New_List
(Init_Loop
)));
7488 if Debug_Generated_Code
then
7489 Set_Debug_Info_Needed
(Counter_Id
);
7492 -- Otherwise previous errors or a missing full view may prevent the
7493 -- proper freezing of the component type. If this is the case, there
7494 -- is no [Deep_]Initialize primitive to call.
7497 Init_Block
:= Make_Null_Statement
(Loc
);
7500 return New_List
(Init_Block
);
7501 end Build_Initialize_Statements
;
7503 -----------------------
7504 -- New_References_To --
7505 -----------------------
7507 function New_References_To
7509 Loc
: Source_Ptr
) return List_Id
7511 Refs
: constant List_Id
:= New_List
;
7516 while Present
(Id
) loop
7517 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
7522 end New_References_To
;
7524 -- Start of processing for Make_Deep_Array_Body
7528 when Address_Case
=>
7529 return Make_Finalize_Address_Stmts
(Typ
);
7534 return Build_Adjust_Or_Finalize_Statements
(Typ
);
7536 when Initialize_Case
=>
7537 return Build_Initialize_Statements
(Typ
);
7539 end Make_Deep_Array_Body
;
7541 --------------------
7542 -- Make_Deep_Proc --
7543 --------------------
7545 function Make_Deep_Proc
7546 (Prim
: Final_Primitives
;
7548 Stmts
: List_Id
) return Entity_Id
7550 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7552 Proc_Id
: Entity_Id
;
7555 -- Create the object formal, generate:
7556 -- V : System.Address
7558 if Prim
= Address_Case
then
7559 Formals
:= New_List
(
7560 Make_Parameter_Specification
(Loc
,
7561 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7563 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7570 Formals
:= New_List
(
7571 Make_Parameter_Specification
(Loc
,
7572 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
7574 Out_Present
=> True,
7575 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
7577 -- F : Boolean := True
7579 if Prim
= Adjust_Case
7580 or else Prim
= Finalize_Case
7583 Make_Parameter_Specification
(Loc
,
7584 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
7586 New_Occurrence_Of
(Standard_Boolean
, Loc
),
7588 New_Occurrence_Of
(Standard_True
, Loc
)));
7593 Make_Defining_Identifier
(Loc
,
7594 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
7597 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
7600 -- exception -- Finalize and Adjust cases only
7601 -- raise Program_Error;
7602 -- end Deep_Initialize / Adjust / Finalize;
7606 -- procedure Finalize_Address (V : System.Address) is
7609 -- end Finalize_Address;
7612 Make_Subprogram_Body
(Loc
,
7614 Make_Procedure_Specification
(Loc
,
7615 Defining_Unit_Name
=> Proc_Id
,
7616 Parameter_Specifications
=> Formals
),
7618 Declarations
=> Empty_List
,
7620 Handled_Statement_Sequence
=>
7621 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
7623 -- If there are no calls to component initialization, indicate that
7624 -- the procedure is trivial, so prevent calls to it.
7626 if Is_Empty_List
(Stmts
)
7627 or else Nkind
(First
(Stmts
)) = N_Null_Statement
7629 Set_Is_Trivial_Subprogram
(Proc_Id
);
7635 ---------------------------
7636 -- Make_Deep_Record_Body --
7637 ---------------------------
7639 function Make_Deep_Record_Body
7640 (Prim
: Final_Primitives
;
7642 Is_Local
: Boolean := False) return List_Id
7644 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
7645 -- Build the statements necessary to adjust a record type. The type may
7646 -- have discriminants and contain variant parts. Generate:
7650 -- [Deep_]Adjust (V.Comp_1);
7652 -- when Id : others =>
7653 -- if not Raised then
7655 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7660 -- [Deep_]Adjust (V.Comp_N);
7662 -- when Id : others =>
7663 -- if not Raised then
7665 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7670 -- Deep_Adjust (V._parent, False); -- If applicable
7672 -- when Id : others =>
7673 -- if not Raised then
7675 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7681 -- Adjust (V); -- If applicable
7684 -- if not Raised then
7686 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7691 -- if Raised and then not Abort then
7692 -- Raise_From_Controlled_Operation (E);
7696 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
7697 -- Build the statements necessary to finalize a record type. The type
7698 -- may have discriminants and contain variant parts. Generate:
7701 -- Abort : constant Boolean := Triggered_By_Abort;
7703 -- Abort : constant Boolean := False; -- no abort
7704 -- E : Exception_Occurrence;
7705 -- Raised : Boolean := False;
7710 -- Finalize (V); -- If applicable
7713 -- if not Raised then
7715 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7720 -- case Variant_1 is
7722 -- case State_Counter_N => -- If Is_Local is enabled
7732 -- <<LN>> -- If Is_Local is enabled
7734 -- [Deep_]Finalize (V.Comp_N);
7737 -- if not Raised then
7739 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7745 -- [Deep_]Finalize (V.Comp_1);
7748 -- if not Raised then
7750 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7756 -- case State_Counter_1 => -- If Is_Local is enabled
7762 -- Deep_Finalize (V._parent, False); -- If applicable
7764 -- when Id : others =>
7765 -- if not Raised then
7767 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7771 -- if Raised and then not Abort then
7772 -- Raise_From_Controlled_Operation (E);
7776 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7777 -- Given a derived tagged type Typ, traverse all components, find field
7778 -- _parent and return its type.
7780 procedure Preprocess_Components
7782 Num_Comps
: out Nat
;
7783 Has_POC
: out Boolean);
7784 -- Examine all components in component list Comps, count all controlled
7785 -- components and determine whether at least one of them is per-object
7786 -- constrained. Component _parent is always skipped.
7788 -----------------------------
7789 -- Build_Adjust_Statements --
7790 -----------------------------
7792 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7793 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7794 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7796 Finalizer_Data
: Finalization_Exception_Data
;
7798 function Process_Component_List_For_Adjust
7799 (Comps
: Node_Id
) return List_Id
;
7800 -- Build all necessary adjust statements for a single component list
7802 ---------------------------------------
7803 -- Process_Component_List_For_Adjust --
7804 ---------------------------------------
7806 function Process_Component_List_For_Adjust
7807 (Comps
: Node_Id
) return List_Id
7809 Stmts
: constant List_Id
:= New_List
;
7811 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7812 -- Process the declaration of a single controlled component
7814 ----------------------------------
7815 -- Process_Component_For_Adjust --
7816 ----------------------------------
7818 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7819 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7820 Typ
: constant Entity_Id
:= Etype
(Id
);
7826 -- [Deep_]Adjust (V.Id);
7830 -- if not Raised then
7832 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7839 Make_Selected_Component
(Loc
,
7840 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7841 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7844 -- Guard against a missing [Deep_]Adjust when the component
7845 -- type was not properly frozen.
7847 if Present
(Adj_Call
) then
7848 if Exceptions_OK
then
7850 Make_Block_Statement
(Loc
,
7851 Handled_Statement_Sequence
=>
7852 Make_Handled_Sequence_Of_Statements
(Loc
,
7853 Statements
=> New_List
(Adj_Call
),
7854 Exception_Handlers
=> New_List
(
7855 Build_Exception_Handler
(Finalizer_Data
))));
7858 Append_To
(Stmts
, Adj_Call
);
7860 end Process_Component_For_Adjust
;
7865 Decl_Id
: Entity_Id
;
7866 Decl_Typ
: Entity_Id
;
7871 -- Start of processing for Process_Component_List_For_Adjust
7874 -- Perform an initial check, determine the number of controlled
7875 -- components in the current list and whether at least one of them
7876 -- is per-object constrained.
7878 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7880 -- The processing in this routine is done in the following order:
7881 -- 1) Regular components
7882 -- 2) Per-object constrained components
7885 if Num_Comps
> 0 then
7887 -- Process all regular components in order of declarations
7889 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7890 while Present
(Decl
) loop
7891 Decl_Id
:= Defining_Identifier
(Decl
);
7892 Decl_Typ
:= Etype
(Decl_Id
);
7894 -- Skip _parent as well as per-object constrained components
7896 if Chars
(Decl_Id
) /= Name_uParent
7897 and then Needs_Finalization
(Decl_Typ
)
7899 if Has_Access_Constraint
(Decl_Id
)
7900 and then No
(Expression
(Decl
))
7904 Process_Component_For_Adjust
(Decl
);
7908 Next_Non_Pragma
(Decl
);
7911 -- Process all per-object constrained components in order of
7915 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7916 while Present
(Decl
) loop
7917 Decl_Id
:= Defining_Identifier
(Decl
);
7918 Decl_Typ
:= Etype
(Decl_Id
);
7922 if Chars
(Decl_Id
) /= Name_uParent
7923 and then Needs_Finalization
(Decl_Typ
)
7924 and then Has_Access_Constraint
(Decl_Id
)
7925 and then No
(Expression
(Decl
))
7927 Process_Component_For_Adjust
(Decl
);
7930 Next_Non_Pragma
(Decl
);
7935 -- Process all variants, if any
7938 if Present
(Variant_Part
(Comps
)) then
7940 Var_Alts
: constant List_Id
:= New_List
;
7944 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7945 while Present
(Var
) loop
7948 -- when <discrete choices> =>
7949 -- <adjust statements>
7951 Append_To
(Var_Alts
,
7952 Make_Case_Statement_Alternative
(Loc
,
7954 New_Copy_List
(Discrete_Choices
(Var
)),
7956 Process_Component_List_For_Adjust
(
7957 Component_List
(Var
))));
7959 Next_Non_Pragma
(Var
);
7963 -- case V.<discriminant> is
7964 -- when <discrete choices 1> =>
7965 -- <adjust statements 1>
7967 -- when <discrete choices N> =>
7968 -- <adjust statements N>
7972 Make_Case_Statement
(Loc
,
7974 Make_Selected_Component
(Loc
,
7975 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7977 Make_Identifier
(Loc
,
7978 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7979 Alternatives
=> Var_Alts
);
7983 -- Add the variant case statement to the list of statements
7985 if Present
(Var_Case
) then
7986 Append_To
(Stmts
, Var_Case
);
7989 -- If the component list did not have any controlled components
7990 -- nor variants, return null.
7992 if Is_Empty_List
(Stmts
) then
7993 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7997 end Process_Component_List_For_Adjust
;
8001 Bod_Stmts
: List_Id
:= No_List
;
8002 Finalizer_Decls
: List_Id
:= No_List
;
8005 -- Start of processing for Build_Adjust_Statements
8008 Finalizer_Decls
:= New_List
;
8009 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
8011 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
8012 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
8017 -- Create an adjust sequence for all record components
8019 if Present
(Component_List
(Rec_Def
)) then
8021 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
8024 -- A derived record type must adjust all inherited components. This
8025 -- action poses the following problem:
8027 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
8032 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
8034 -- Deep_Adjust (Obj._parent);
8039 -- Adjusting the derived type will invoke Adjust of the parent and
8040 -- then that of the derived type. This is undesirable because both
8041 -- routines may modify shared components. Only the Adjust of the
8042 -- derived type should be invoked.
8044 -- To prevent this double adjustment of shared components,
8045 -- Deep_Adjust uses a flag to control the invocation of Adjust:
8047 -- procedure Deep_Adjust
8048 -- (Obj : in out Some_Type;
8049 -- Flag : Boolean := True)
8057 -- When Deep_Adjust is invoked for field _parent, a value of False is
8058 -- provided for the flag:
8060 -- Deep_Adjust (Obj._parent, False);
8062 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8064 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
8069 if Needs_Finalization
(Par_Typ
) then
8073 Make_Selected_Component
(Loc
,
8074 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8076 Make_Identifier
(Loc
, Name_uParent
)),
8082 -- Deep_Adjust (V._parent, False);
8085 -- when Id : others =>
8086 -- if not Raised then
8088 -- Save_Occurrence (E,
8089 -- Get_Current_Excep.all.all);
8093 if Present
(Call
) then
8096 if Exceptions_OK
then
8098 Make_Block_Statement
(Loc
,
8099 Handled_Statement_Sequence
=>
8100 Make_Handled_Sequence_Of_Statements
(Loc
,
8101 Statements
=> New_List
(Adj_Stmt
),
8102 Exception_Handlers
=> New_List
(
8103 Build_Exception_Handler
(Finalizer_Data
))));
8106 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
8112 -- Adjust the object. This action must be performed last after all
8113 -- components have been adjusted.
8115 if Is_Controlled
(Typ
) then
8121 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
8130 -- if not Raised then
8132 -- Save_Occurrence (E,
8133 -- Get_Current_Excep.all.all);
8138 if Present
(Proc
) then
8140 Make_Procedure_Call_Statement
(Loc
,
8141 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8142 Parameter_Associations
=> New_List
(
8143 Make_Identifier
(Loc
, Name_V
)));
8145 if Exceptions_OK
then
8147 Make_Block_Statement
(Loc
,
8148 Handled_Statement_Sequence
=>
8149 Make_Handled_Sequence_Of_Statements
(Loc
,
8150 Statements
=> New_List
(Adj_Stmt
),
8151 Exception_Handlers
=> New_List
(
8152 Build_Exception_Handler
8153 (Finalizer_Data
))));
8156 Append_To
(Bod_Stmts
,
8157 Make_If_Statement
(Loc
,
8158 Condition
=> Make_Identifier
(Loc
, Name_F
),
8159 Then_Statements
=> New_List
(Adj_Stmt
)));
8164 -- At this point either all adjustment statements have been generated
8165 -- or the type is not controlled.
8167 if Is_Empty_List
(Bod_Stmts
) then
8168 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
8174 -- Abort : constant Boolean := Triggered_By_Abort;
8176 -- Abort : constant Boolean := False; -- no abort
8178 -- E : Exception_Occurrence;
8179 -- Raised : Boolean := False;
8182 -- <adjust statements>
8184 -- if Raised and then not Abort then
8185 -- Raise_From_Controlled_Operation (E);
8190 if Exceptions_OK
then
8191 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8196 Make_Block_Statement
(Loc
,
8199 Handled_Statement_Sequence
=>
8200 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8202 end Build_Adjust_Statements
;
8204 -------------------------------
8205 -- Build_Finalize_Statements --
8206 -------------------------------
8208 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
8209 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8210 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
8213 Finalizer_Data
: Finalization_Exception_Data
;
8214 Last_POC_Call
: Node_Id
:= Empty
;
8216 function Process_Component_List_For_Finalize
8218 In_Variant_Part
: Boolean := False) return List_Id
;
8219 -- Build all necessary finalization statements for a single component
8220 -- list. The statements may include a jump circuitry if flag Is_Local
8221 -- is enabled. In_Variant_Part indicates whether this is a recursive
8224 -----------------------------------------
8225 -- Process_Component_List_For_Finalize --
8226 -----------------------------------------
8228 function Process_Component_List_For_Finalize
8230 In_Variant_Part
: Boolean := False) return List_Id
8232 procedure Process_Component_For_Finalize
8237 Num_Comps
: in out Nat
);
8238 -- Process the declaration of a single controlled component. If
8239 -- flag Is_Local is enabled, create the corresponding label and
8240 -- jump circuitry. Alts is the list of case alternatives, Decls
8241 -- is the top level declaration list where labels are declared
8242 -- and Stmts is the list of finalization actions. Num_Comps
8243 -- denotes the current number of components needing finalization.
8245 ------------------------------------
8246 -- Process_Component_For_Finalize --
8247 ------------------------------------
8249 procedure Process_Component_For_Finalize
8254 Num_Comps
: in out Nat
)
8256 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
8257 Typ
: constant Entity_Id
:= Etype
(Id
);
8264 Label_Id
: Entity_Id
;
8271 Make_Identifier
(Loc
,
8272 Chars
=> New_External_Name
('L', Num_Comps
));
8273 Set_Entity
(Label_Id
,
8274 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
8275 Label
:= Make_Label
(Loc
, Label_Id
);
8278 Make_Implicit_Label_Declaration
(Loc
,
8279 Defining_Identifier
=> Entity
(Label_Id
),
8280 Label_Construct
=> Label
));
8287 Make_Case_Statement_Alternative
(Loc
,
8288 Discrete_Choices
=> New_List
(
8289 Make_Integer_Literal
(Loc
, Num_Comps
)),
8291 Statements
=> New_List
(
8292 Make_Goto_Statement
(Loc
,
8294 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
8299 Append_To
(Stmts
, Label
);
8301 -- Decrease the number of components to be processed.
8302 -- This action yields a new Label_Id in future calls.
8304 Num_Comps
:= Num_Comps
- 1;
8309 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
8311 -- begin -- Exception handlers allowed
8312 -- [Deep_]Finalize (V.Id);
8315 -- if not Raised then
8317 -- Save_Occurrence (E,
8318 -- Get_Current_Excep.all.all);
8325 Make_Selected_Component
(Loc
,
8326 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8327 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
8330 -- Guard against a missing [Deep_]Finalize when the component
8331 -- type was not properly frozen.
8333 if Present
(Fin_Call
) then
8334 if Exceptions_OK
then
8336 Make_Block_Statement
(Loc
,
8337 Handled_Statement_Sequence
=>
8338 Make_Handled_Sequence_Of_Statements
(Loc
,
8339 Statements
=> New_List
(Fin_Call
),
8340 Exception_Handlers
=> New_List
(
8341 Build_Exception_Handler
(Finalizer_Data
))));
8344 Append_To
(Stmts
, Fin_Call
);
8346 end Process_Component_For_Finalize
;
8351 Counter_Id
: Entity_Id
:= Empty
;
8353 Decl_Id
: Entity_Id
;
8354 Decl_Typ
: Entity_Id
;
8357 Jump_Block
: Node_Id
;
8359 Label_Id
: Entity_Id
;
8364 -- Start of processing for Process_Component_List_For_Finalize
8367 -- Perform an initial check, look for controlled and per-object
8368 -- constrained components.
8370 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
8372 -- Create a state counter to service the current component list.
8373 -- This step is performed before the variants are inspected in
8374 -- order to generate the same state counter names as those from
8375 -- Build_Initialize_Statements.
8377 if Num_Comps
> 0 and then Is_Local
then
8378 Counter
:= Counter
+ 1;
8381 Make_Defining_Identifier
(Loc
,
8382 Chars
=> New_External_Name
('C', Counter
));
8385 -- Process the component in the following order:
8387 -- 2) Per-object constrained components
8388 -- 3) Regular components
8390 -- Start with the variant parts
8393 if Present
(Variant_Part
(Comps
)) then
8395 Var_Alts
: constant List_Id
:= New_List
;
8399 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
8400 while Present
(Var
) loop
8403 -- when <discrete choices> =>
8404 -- <finalize statements>
8406 Append_To
(Var_Alts
,
8407 Make_Case_Statement_Alternative
(Loc
,
8409 New_Copy_List
(Discrete_Choices
(Var
)),
8411 Process_Component_List_For_Finalize
(
8412 Component_List
(Var
),
8413 In_Variant_Part
=> True)));
8415 Next_Non_Pragma
(Var
);
8419 -- case V.<discriminant> is
8420 -- when <discrete choices 1> =>
8421 -- <finalize statements 1>
8423 -- when <discrete choices N> =>
8424 -- <finalize statements N>
8428 Make_Case_Statement
(Loc
,
8430 Make_Selected_Component
(Loc
,
8431 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8433 Make_Identifier
(Loc
,
8434 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
8435 Alternatives
=> Var_Alts
);
8439 -- The current component list does not have a single controlled
8440 -- component, however it may contain variants. Return the case
8441 -- statement for the variants or nothing.
8443 if Num_Comps
= 0 then
8444 if Present
(Var_Case
) then
8445 return New_List
(Var_Case
);
8447 return New_List
(Make_Null_Statement
(Loc
));
8451 -- Prepare all lists
8457 -- Process all per-object constrained components in reverse order
8460 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
8461 while Present
(Decl
) loop
8462 Decl_Id
:= Defining_Identifier
(Decl
);
8463 Decl_Typ
:= Etype
(Decl_Id
);
8467 if Chars
(Decl_Id
) /= Name_uParent
8468 and then Needs_Finalization
(Decl_Typ
)
8469 and then Has_Access_Constraint
(Decl_Id
)
8470 and then No
(Expression
(Decl
))
8472 Process_Component_For_Finalize
8473 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
8476 Prev_Non_Pragma
(Decl
);
8480 if not In_Variant_Part
then
8481 Last_POC_Call
:= Last
(Stmts
);
8482 -- In the case of a type extension, the deep-finalize call
8483 -- for the _Parent component will be inserted here.
8486 -- Process the rest of the components in reverse order
8488 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
8489 while Present
(Decl
) loop
8490 Decl_Id
:= Defining_Identifier
(Decl
);
8491 Decl_Typ
:= Etype
(Decl_Id
);
8495 if Chars
(Decl_Id
) /= Name_uParent
8496 and then Needs_Finalization
(Decl_Typ
)
8498 -- Skip per-object constrained components since they were
8499 -- handled in the above step.
8501 if Has_Access_Constraint
(Decl_Id
)
8502 and then No
(Expression
(Decl
))
8506 Process_Component_For_Finalize
8507 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
8511 Prev_Non_Pragma
(Decl
);
8516 -- LN : label; -- If Is_Local is enabled
8521 -- case CounterX is .
8531 -- <<LN>> -- If Is_Local is enabled
8533 -- [Deep_]Finalize (V.CompY);
8535 -- when Id : others =>
8536 -- if not Raised then
8538 -- Save_Occurrence (E,
8539 -- Get_Current_Excep.all.all);
8543 -- <<L0>> -- If Is_Local is enabled
8548 -- Add the declaration of default jump location L0, its
8549 -- corresponding alternative and its place in the statements.
8551 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
8552 Set_Entity
(Label_Id
,
8553 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
8554 Label
:= Make_Label
(Loc
, Label_Id
);
8556 Append_To
(Decls
, -- declaration
8557 Make_Implicit_Label_Declaration
(Loc
,
8558 Defining_Identifier
=> Entity
(Label_Id
),
8559 Label_Construct
=> Label
));
8561 Append_To
(Alts
, -- alternative
8562 Make_Case_Statement_Alternative
(Loc
,
8563 Discrete_Choices
=> New_List
(
8564 Make_Others_Choice
(Loc
)),
8566 Statements
=> New_List
(
8567 Make_Goto_Statement
(Loc
,
8568 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
8570 Append_To
(Stmts
, Label
); -- statement
8572 -- Create the jump block
8575 Make_Case_Statement
(Loc
,
8576 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
8577 Alternatives
=> Alts
));
8581 Make_Block_Statement
(Loc
,
8582 Declarations
=> Decls
,
8583 Handled_Statement_Sequence
=>
8584 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
8586 if Present
(Var_Case
) then
8587 return New_List
(Var_Case
, Jump_Block
);
8589 return New_List
(Jump_Block
);
8591 end Process_Component_List_For_Finalize
;
8595 Bod_Stmts
: List_Id
:= No_List
;
8596 Finalizer_Decls
: List_Id
:= No_List
;
8599 -- Start of processing for Build_Finalize_Statements
8602 Finalizer_Decls
:= New_List
;
8603 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
8605 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
8606 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
8611 -- Create a finalization sequence for all record components
8613 if Present
(Component_List
(Rec_Def
)) then
8615 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
8618 -- A derived record type must finalize all inherited components. This
8619 -- action poses the following problem:
8621 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
8626 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
8628 -- Deep_Finalize (Obj._parent);
8633 -- Finalizing the derived type will invoke Finalize of the parent and
8634 -- then that of the derived type. This is undesirable because both
8635 -- routines may modify shared components. Only the Finalize of the
8636 -- derived type should be invoked.
8638 -- To prevent this double adjustment of shared components,
8639 -- Deep_Finalize uses a flag to control the invocation of Finalize:
8641 -- procedure Deep_Finalize
8642 -- (Obj : in out Some_Type;
8643 -- Flag : Boolean := True)
8651 -- When Deep_Finalize is invoked for field _parent, a value of False
8652 -- is provided for the flag:
8654 -- Deep_Finalize (Obj._parent, False);
8656 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8658 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
8663 if Needs_Finalization
(Par_Typ
) then
8667 Make_Selected_Component
(Loc
,
8668 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8670 Make_Identifier
(Loc
, Name_uParent
)),
8676 -- Deep_Finalize (V._parent, False);
8679 -- when Id : others =>
8680 -- if not Raised then
8682 -- Save_Occurrence (E,
8683 -- Get_Current_Excep.all.all);
8687 if Present
(Call
) then
8690 if Exceptions_OK
then
8692 Make_Block_Statement
(Loc
,
8693 Handled_Statement_Sequence
=>
8694 Make_Handled_Sequence_Of_Statements
(Loc
,
8695 Statements
=> New_List
(Fin_Stmt
),
8696 Exception_Handlers
=> New_List
(
8697 Build_Exception_Handler
8698 (Finalizer_Data
))));
8701 -- The intended component finalization order is
8702 -- 1) POC components of extension
8703 -- 2) _Parent component
8704 -- 3) non-POC components of extension.
8706 -- With this "finalize the parent part in the middle"
8707 -- ordering, we can avoid the need for making two
8708 -- calls to the parent's subprogram in the way that
8709 -- is necessary for Init_Procs. This does have the
8710 -- peculiar (but legal) consequence that the parent's
8711 -- non-POC components are finalized before the
8712 -- non-POC extension components. This violates the
8713 -- usual "finalize in reverse declaration order"
8714 -- principle, but that's ok (see Ada RM 7.6.1(9)).
8716 -- Last_POC_Call should be non-empty if the extension
8717 -- has at least one POC. Interactions with variant
8718 -- parts are incorrectly ignored.
8720 if Present
(Last_POC_Call
) then
8721 Insert_After
(Last_POC_Call
, Fin_Stmt
);
8723 -- At this point, we could look for the common case
8724 -- where there are no POC components anywhere in
8725 -- sight (inherited or not) and, in that common case,
8726 -- call Append_To instead of Prepend_To. That would
8727 -- result in finalizing the parent part after, rather
8728 -- than before, the extension components. That might
8729 -- be more intuitive (as discussed in preceding
8730 -- comment), but it is not required.
8731 Prepend_To
(Bod_Stmts
, Fin_Stmt
);
8738 -- Finalize the object. This action must be performed first before
8739 -- all components have been finalized.
8741 if Is_Controlled
(Typ
) and then not Is_Local
then
8747 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8756 -- if not Raised then
8758 -- Save_Occurrence (E,
8759 -- Get_Current_Excep.all.all);
8764 if Present
(Proc
) then
8766 Make_Procedure_Call_Statement
(Loc
,
8767 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8768 Parameter_Associations
=> New_List
(
8769 Make_Identifier
(Loc
, Name_V
)));
8771 if Exceptions_OK
then
8773 Make_Block_Statement
(Loc
,
8774 Handled_Statement_Sequence
=>
8775 Make_Handled_Sequence_Of_Statements
(Loc
,
8776 Statements
=> New_List
(Fin_Stmt
),
8777 Exception_Handlers
=> New_List
(
8778 Build_Exception_Handler
8779 (Finalizer_Data
))));
8782 Prepend_To
(Bod_Stmts
,
8783 Make_If_Statement
(Loc
,
8784 Condition
=> Make_Identifier
(Loc
, Name_F
),
8785 Then_Statements
=> New_List
(Fin_Stmt
)));
8790 -- At this point either all finalization statements have been
8791 -- generated or the type is not controlled.
8793 if No
(Bod_Stmts
) then
8794 return New_List
(Make_Null_Statement
(Loc
));
8798 -- Abort : constant Boolean := Triggered_By_Abort;
8800 -- Abort : constant Boolean := False; -- no abort
8802 -- E : Exception_Occurrence;
8803 -- Raised : Boolean := False;
8806 -- <finalize statements>
8808 -- if Raised and then not Abort then
8809 -- Raise_From_Controlled_Operation (E);
8814 if Exceptions_OK
then
8815 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8820 Make_Block_Statement
(Loc
,
8823 Handled_Statement_Sequence
=>
8824 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8826 end Build_Finalize_Statements
;
8828 -----------------------
8829 -- Parent_Field_Type --
8830 -----------------------
8832 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8836 Field
:= First_Entity
(Typ
);
8837 while Present
(Field
) loop
8838 if Chars
(Field
) = Name_uParent
then
8839 return Etype
(Field
);
8842 Next_Entity
(Field
);
8845 -- A derived tagged type should always have a parent field
8847 raise Program_Error
;
8848 end Parent_Field_Type
;
8850 ---------------------------
8851 -- Preprocess_Components --
8852 ---------------------------
8854 procedure Preprocess_Components
8856 Num_Comps
: out Nat
;
8857 Has_POC
: out Boolean)
8867 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8868 while Present
(Decl
) loop
8869 Id
:= Defining_Identifier
(Decl
);
8872 -- Skip field _parent
8874 if Chars
(Id
) /= Name_uParent
8875 and then Needs_Finalization
(Typ
)
8877 Num_Comps
:= Num_Comps
+ 1;
8879 if Has_Access_Constraint
(Id
)
8880 and then No
(Expression
(Decl
))
8886 Next_Non_Pragma
(Decl
);
8888 end Preprocess_Components
;
8890 -- Start of processing for Make_Deep_Record_Body
8894 when Address_Case
=>
8895 return Make_Finalize_Address_Stmts
(Typ
);
8898 return Build_Adjust_Statements
(Typ
);
8900 when Finalize_Case
=>
8901 return Build_Finalize_Statements
(Typ
);
8903 when Initialize_Case
=>
8905 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8908 if Is_Controlled
(Typ
) then
8910 Make_Procedure_Call_Statement
(Loc
,
8913 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8914 Parameter_Associations
=> New_List
(
8915 Make_Identifier
(Loc
, Name_V
))));
8921 end Make_Deep_Record_Body
;
8923 ----------------------
8924 -- Make_Final_Call --
8925 ----------------------
8927 function Make_Final_Call
8930 Skip_Self
: Boolean := False) return Node_Id
8932 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8934 Prot_Typ
: Entity_Id
:= Empty
;
8935 Fin_Id
: Entity_Id
:= Empty
;
8942 -- Recover the proper type which contains [Deep_]Finalize
8944 if Is_Class_Wide_Type
(Typ
) then
8945 Utyp
:= Root_Type
(Typ
);
8948 elsif Is_Concurrent_Type
(Typ
) then
8949 Utyp
:= Corresponding_Record_Type
(Typ
);
8951 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8953 elsif Is_Private_Type
(Typ
)
8954 and then Present
(Underlying_Type
(Typ
))
8955 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8957 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8959 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8966 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8967 Set_Assignment_OK
(Ref
);
8969 -- Deal with untagged derivation of private views. If the parent type
8970 -- is a protected type, Deep_Finalize is found on the corresponding
8971 -- record of the ancestor.
8973 if Is_Untagged_Derivation
(Typ
) then
8974 if Is_Protected_Type
(Typ
) then
8975 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8977 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8979 if Is_Protected_Type
(Utyp
) then
8980 Utyp
:= Corresponding_Record_Type
(Utyp
);
8984 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8985 Set_Assignment_OK
(Ref
);
8988 -- Deal with derived private types which do not inherit primitives from
8989 -- their parents. In this case, [Deep_]Finalize can be found in the full
8990 -- view of the parent type.
8993 and then Is_Tagged_Type
(Utyp
)
8994 and then Is_Derived_Type
(Utyp
)
8995 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8996 and then Is_Private_Type
(Etype
(Utyp
))
8997 and then Present
(Full_View
(Etype
(Utyp
)))
8999 Utyp
:= Full_View
(Etype
(Utyp
));
9000 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9001 Set_Assignment_OK
(Ref
);
9004 -- When dealing with the completion of a private type, use the base type
9007 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
9008 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
9010 Utyp
:= Base_Type
(Utyp
);
9011 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9012 Set_Assignment_OK
(Ref
);
9015 -- Detect if Typ is a protected type or an expanded protected type and
9016 -- store the relevant type within Prot_Typ for later processing.
9018 if Is_Protected_Type
(Typ
) then
9021 elsif Ekind
(Typ
) = E_Record_Type
9022 and then Present
(Corresponding_Concurrent_Type
(Typ
))
9023 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Typ
))
9025 Prot_Typ
:= Corresponding_Concurrent_Type
(Typ
);
9028 -- The underlying type may not be present due to a missing full view. In
9029 -- this case freezing did not take place and there is no [Deep_]Finalize
9030 -- primitive to call.
9035 elsif Skip_Self
then
9036 if Has_Controlled_Component
(Utyp
) then
9037 if Is_Tagged_Type
(Utyp
) then
9038 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9040 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
9044 -- Class-wide types, interfaces and types with controlled components
9046 elsif Is_Class_Wide_Type
(Typ
)
9047 or else Is_Interface
(Typ
)
9048 or else Has_Controlled_Component
(Utyp
)
9050 if Is_Tagged_Type
(Utyp
) then
9051 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9053 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
9056 -- Derivations from [Limited_]Controlled
9058 elsif Is_Controlled
(Utyp
) then
9059 if Has_Controlled_Component
(Utyp
) then
9060 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9062 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
9067 elsif Is_Tagged_Type
(Utyp
) then
9068 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
9070 -- Protected types: these also require finalization even though they
9071 -- are not marked controlled explicitly.
9073 elsif Present
(Prot_Typ
) then
9074 -- Protected objects do not need to be finalized on restricted
9077 if Restricted_Profile
then
9080 -- ??? Only handle the simple case for now. Will not support a record
9081 -- or array containing protected objects.
9083 elsif Is_Simple_Protected_Type
(Prot_Typ
) then
9084 Fin_Id
:= RTE
(RE_Finalize_Protection
);
9086 raise Program_Error
;
9089 raise Program_Error
;
9092 if Present
(Fin_Id
) then
9094 -- When finalizing a class-wide object, do not convert to the root
9095 -- type in order to produce a dispatching call.
9097 if Is_Class_Wide_Type
(Typ
) then
9100 -- Ensure that a finalization routine is at least decorated in order
9101 -- to inspect the object parameter.
9103 elsif Analyzed
(Fin_Id
)
9104 or else Ekind
(Fin_Id
) = E_Procedure
9106 -- In certain cases, such as the creation of Stream_Read, the
9107 -- visible entity of the type is its full view. Since Stream_Read
9108 -- will have to create an object of type Typ, the local object
9109 -- will be finalzed by the scope finalizer generated later on. The
9110 -- object parameter of Deep_Finalize will always use the private
9111 -- view of the type. To avoid such a clash between a private and a
9112 -- full view, perform an unchecked conversion of the object
9113 -- reference to the private view.
9116 Formal_Typ
: constant Entity_Id
:=
9117 Etype
(First_Formal
(Fin_Id
));
9119 if Is_Private_Type
(Formal_Typ
)
9120 and then Present
(Full_View
(Formal_Typ
))
9121 and then Full_View
(Formal_Typ
) = Utyp
9123 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
9127 -- If the object is unanalyzed, set its expected type for use in
9128 -- Convert_View in case an additional conversion is needed.
9131 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
9133 Set_Etype
(Ref
, Typ
);
9136 Ref
:= Convert_View
(Fin_Id
, Ref
);
9143 Skip_Self
=> Skip_Self
);
9147 end Make_Final_Call
;
9149 --------------------------------
9150 -- Make_Finalize_Address_Body --
9151 --------------------------------
9153 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
9154 Is_Task
: constant Boolean :=
9155 Ekind
(Typ
) = E_Record_Type
9156 and then Is_Concurrent_Record_Type
(Typ
)
9157 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
9159 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
9160 Proc_Id
: Entity_Id
;
9164 -- The corresponding records of task types are not controlled by design.
9165 -- For the sake of completeness, create an empty Finalize_Address to be
9166 -- used in task class-wide allocations.
9171 -- Nothing to do if the type is not controlled or it already has a
9172 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
9173 -- come from source. These are usually generated for completeness and
9174 -- do not need the Finalize_Address primitive.
9176 elsif not Needs_Finalization
(Typ
)
9177 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
9179 (Is_Class_Wide_Type
(Typ
)
9180 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
9181 and then not Comes_From_Source
(Root_Type
(Typ
)))
9186 -- Do not generate Finalize_Address routine for CodePeer
9188 if CodePeer_Mode
then
9193 Make_Defining_Identifier
(Loc
,
9194 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
9198 -- procedure <Typ>FD (V : System.Address) is
9200 -- null; -- for tasks
9202 -- declare -- for all other types
9203 -- type Pnn is access all Typ;
9204 -- for Pnn'Storage_Size use 0;
9206 -- [Deep_]Finalize (Pnn (V).all);
9211 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
9213 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
9217 Make_Subprogram_Body
(Loc
,
9219 Make_Procedure_Specification
(Loc
,
9220 Defining_Unit_Name
=> Proc_Id
,
9222 Parameter_Specifications
=> New_List
(
9223 Make_Parameter_Specification
(Loc
,
9224 Defining_Identifier
=>
9225 Make_Defining_Identifier
(Loc
, Name_V
),
9227 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
9229 Declarations
=> No_List
,
9231 Handled_Statement_Sequence
=>
9232 Make_Handled_Sequence_Of_Statements
(Loc
,
9233 Statements
=> Stmts
)));
9235 Set_TSS
(Typ
, Proc_Id
);
9236 end Make_Finalize_Address_Body
;
9238 ---------------------------------
9239 -- Make_Finalize_Address_Stmts --
9240 ---------------------------------
9242 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
9243 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
9246 Desig_Typ
: Entity_Id
;
9247 Fin_Block
: Node_Id
;
9250 Ptr_Typ
: Entity_Id
;
9253 if Is_Array_Type
(Typ
) then
9254 if Is_Constrained
(First_Subtype
(Typ
)) then
9255 Desig_Typ
:= First_Subtype
(Typ
);
9257 Desig_Typ
:= Base_Type
(Typ
);
9260 -- Class-wide types of constrained root types
9262 elsif Is_Class_Wide_Type
(Typ
)
9263 and then Has_Discriminants
(Root_Type
(Typ
))
9265 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
9268 Parent_Typ
: Entity_Id
;
9271 -- Climb the parent type chain looking for a non-constrained type
9273 Parent_Typ
:= Root_Type
(Typ
);
9274 while Parent_Typ
/= Etype
(Parent_Typ
)
9275 and then Has_Discriminants
(Parent_Typ
)
9277 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
9279 Parent_Typ
:= Etype
(Parent_Typ
);
9282 -- Handle views created for tagged types with unknown
9285 if Is_Underlying_Record_View
(Parent_Typ
) then
9286 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
9289 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
9299 -- type Ptr_Typ is access all Typ;
9300 -- for Ptr_Typ'Storage_Size use 0;
9302 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
9305 Make_Full_Type_Declaration
(Loc
,
9306 Defining_Identifier
=> Ptr_Typ
,
9308 Make_Access_To_Object_Definition
(Loc
,
9309 All_Present
=> True,
9310 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
9312 Make_Attribute_Definition_Clause
(Loc
,
9313 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
9314 Chars
=> Name_Storage_Size
,
9315 Expression
=> Make_Integer_Literal
(Loc
, 0)));
9317 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
9319 -- Unconstrained arrays require special processing in order to retrieve
9320 -- the elements. To achieve this, we have to skip the dope vector which
9321 -- lays in front of the elements and then use a thin pointer to perform
9322 -- the address-to-access conversion.
9324 if Is_Array_Type
(Typ
)
9325 and then not Is_Constrained
(First_Subtype
(Typ
))
9328 Dope_Id
: Entity_Id
;
9331 -- Ensure that Ptr_Typ is a thin pointer; generate:
9332 -- for Ptr_Typ'Size use System.Address'Size;
9335 Make_Attribute_Definition_Clause
(Loc
,
9336 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
9339 Make_Integer_Literal
(Loc
, System_Address_Size
)));
9342 -- Dnn : constant Storage_Offset :=
9343 -- Desig_Typ'Descriptor_Size / Storage_Unit;
9345 Dope_Id
:= Make_Temporary
(Loc
, 'D');
9348 Make_Object_Declaration
(Loc
,
9349 Defining_Identifier
=> Dope_Id
,
9350 Constant_Present
=> True,
9351 Object_Definition
=>
9352 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
9354 Make_Op_Divide
(Loc
,
9356 Make_Attribute_Reference
(Loc
,
9357 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
9358 Attribute_Name
=> Name_Descriptor_Size
),
9360 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
9362 -- Shift the address from the start of the dope vector to the
9363 -- start of the elements:
9367 -- Note that this is done through a wrapper routine since RTSfind
9368 -- cannot retrieve operations with string names of the form "+".
9371 Make_Function_Call
(Loc
,
9373 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
9374 Parameter_Associations
=> New_List
(
9376 New_Occurrence_Of
(Dope_Id
, Loc
)));
9383 Make_Explicit_Dereference
(Loc
,
9384 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
9387 if Present
(Fin_Call
) then
9389 Make_Block_Statement
(Loc
,
9390 Declarations
=> Decls
,
9391 Handled_Statement_Sequence
=>
9392 Make_Handled_Sequence_Of_Statements
(Loc
,
9393 Statements
=> New_List
(Fin_Call
)));
9395 -- Otherwise previous errors or a missing full view may prevent the
9396 -- proper freezing of the designated type. If this is the case, there
9397 -- is no [Deep_]Finalize primitive to call.
9400 Fin_Block
:= Make_Null_Statement
(Loc
);
9403 return New_List
(Fin_Block
);
9404 end Make_Finalize_Address_Stmts
;
9406 -------------------------------------
9407 -- Make_Handler_For_Ctrl_Operation --
9408 -------------------------------------
9412 -- when E : others =>
9413 -- Raise_From_Controlled_Operation (E);
9418 -- raise Program_Error [finalize raised exception];
9420 -- depending on whether Raise_From_Controlled_Operation is available
9422 function Make_Handler_For_Ctrl_Operation
9423 (Loc
: Source_Ptr
) return Node_Id
9426 -- Choice parameter (for the first case above)
9428 Raise_Node
: Node_Id
;
9429 -- Procedure call or raise statement
9432 -- Standard run-time: add choice parameter E and pass it to
9433 -- Raise_From_Controlled_Operation so that the original exception
9434 -- name and message can be recorded in the exception message for
9437 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
9438 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
9440 Make_Procedure_Call_Statement
(Loc
,
9443 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
9444 Parameter_Associations
=> New_List
(
9445 New_Occurrence_Of
(E_Occ
, Loc
)));
9447 -- Restricted run-time: exception messages are not supported
9452 Make_Raise_Program_Error
(Loc
,
9453 Reason
=> PE_Finalize_Raised_Exception
);
9457 Make_Implicit_Exception_Handler
(Loc
,
9458 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
9459 Choice_Parameter
=> E_Occ
,
9460 Statements
=> New_List
(Raise_Node
));
9461 end Make_Handler_For_Ctrl_Operation
;
9463 --------------------
9464 -- Make_Init_Call --
9465 --------------------
9467 function Make_Init_Call
9469 Typ
: Entity_Id
) return Node_Id
9471 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
9480 -- Deal with the type and object reference. Depending on the context, an
9481 -- object reference may need several conversions.
9483 if Is_Concurrent_Type
(Typ
) then
9485 Utyp
:= Corresponding_Record_Type
(Typ
);
9486 Ref
:= Convert_Concurrent
(Ref
, Typ
);
9488 elsif Is_Private_Type
(Typ
)
9489 and then Present
(Full_View
(Typ
))
9490 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
9493 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
9494 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
9501 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
9502 Set_Assignment_OK
(Ref
);
9504 -- Deal with untagged derivation of private views
9506 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
9507 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
9508 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9510 -- The following is to prevent problems with UC see 1.156 RH ???
9512 Set_Assignment_OK
(Ref
);
9515 -- If the underlying_type is a subtype, then we are dealing with the
9516 -- completion of a private type. We need to access the base type and
9517 -- generate a conversion to it.
9519 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
9520 pragma Assert
(Is_Private_Type
(Typ
));
9521 Utyp
:= Base_Type
(Utyp
);
9522 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
9525 -- The underlying type may not be present due to a missing full view.
9526 -- In this case freezing did not take place and there is no suitable
9527 -- [Deep_]Initialize primitive to call.
9528 -- If Typ is protected then no additional processing is needed either.
9531 or else Is_Protected_Type
(Typ
)
9536 -- Select the appropriate version of initialize
9538 if Has_Controlled_Component
(Utyp
) then
9539 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
9541 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
9542 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
9545 -- If initialization procedure for an array of controlled objects is
9546 -- trivial, do not generate a useless call to it.
9547 -- The initialization procedure may be missing altogether in the case
9548 -- of a derived container whose components have trivial initialization.
9551 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
9553 (not Comes_From_Source
(Proc
)
9554 and then Present
(Alias
(Proc
))
9555 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
9560 -- The object reference may need another conversion depending on the
9561 -- type of the formal and that of the actual.
9563 Ref
:= Convert_View
(Proc
, Ref
);
9566 -- [Deep_]Initialize (Ref);
9569 Make_Procedure_Call_Statement
(Loc
,
9570 Name
=> New_Occurrence_Of
(Proc
, Loc
),
9571 Parameter_Associations
=> New_List
(Ref
));
9574 ------------------------------
9575 -- Make_Local_Deep_Finalize --
9576 ------------------------------
9578 function Make_Local_Deep_Finalize
9580 Nam
: Entity_Id
) return Node_Id
9582 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
9586 Formals
:= New_List
(
9590 Make_Parameter_Specification
(Loc
,
9591 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
9593 Out_Present
=> True,
9594 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
9596 -- F : Boolean := True
9598 Make_Parameter_Specification
(Loc
,
9599 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
9600 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
9601 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
9603 -- Add the necessary number of counters to represent the initialization
9604 -- state of an object.
9607 Make_Subprogram_Body
(Loc
,
9609 Make_Procedure_Specification
(Loc
,
9610 Defining_Unit_Name
=> Nam
,
9611 Parameter_Specifications
=> Formals
),
9613 Declarations
=> No_List
,
9615 Handled_Statement_Sequence
=>
9616 Make_Handled_Sequence_Of_Statements
(Loc
,
9617 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
9618 end Make_Local_Deep_Finalize
;
9620 ------------------------------------
9621 -- Make_Set_Finalize_Address_Call --
9622 ------------------------------------
9624 function Make_Set_Finalize_Address_Call
9626 Ptr_Typ
: Entity_Id
) return Node_Id
9628 -- It is possible for Ptr_Typ to be a partial view, if the access type
9629 -- is a full view declared in the private part of a nested package, and
9630 -- the finalization actions take place when completing analysis of the
9631 -- enclosing unit. For this reason use Underlying_Type twice below.
9633 Desig_Typ
: constant Entity_Id
:=
9635 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
9636 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
9637 Fin_Mas
: constant Entity_Id
:=
9638 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
9641 -- Both the finalization master and primitive Finalize_Address must be
9644 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
9647 -- Set_Finalize_Address
9648 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
9651 Make_Procedure_Call_Statement
(Loc
,
9653 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
9654 Parameter_Associations
=> New_List
(
9655 New_Occurrence_Of
(Fin_Mas
, Loc
),
9657 Make_Attribute_Reference
(Loc
,
9658 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
9659 Attribute_Name
=> Name_Unrestricted_Access
)));
9660 end Make_Set_Finalize_Address_Call
;
9662 --------------------------
9663 -- Make_Transient_Block --
9664 --------------------------
9666 function Make_Transient_Block
9669 Par
: Node_Id
) return Node_Id
9671 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
9672 -- Determine whether scoping entity Id manages the secondary stack
9674 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
9675 -- Return True when N appears within a loop and no block is containing N
9677 -----------------------
9678 -- Manages_Sec_Stack --
9679 -----------------------
9681 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
9685 -- An exception handler with a choice parameter utilizes a dummy
9686 -- block to provide a declarative region. Such a block should not
9687 -- be considered because it never manifests in the tree and can
9688 -- never release the secondary stack.
9692 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
9699 return Uses_Sec_Stack
(Id
);
9704 end Manages_Sec_Stack
;
9706 ---------------------------
9707 -- Within_Loop_Statement --
9708 ---------------------------
9710 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
9711 Par
: Node_Id
:= Parent
(N
);
9714 while Nkind
(Par
) not in
9715 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9716 N_Package_Specification | N_Proper_Body
9718 pragma Assert
(Present
(Par
));
9719 Par
:= Parent
(Par
);
9722 return Nkind
(Par
) = N_Loop_Statement
;
9723 end Within_Loop_Statement
;
9727 Decls
: constant List_Id
:= New_List
;
9728 Instrs
: constant List_Id
:= New_List
(Action
);
9729 Trans_Id
: constant Entity_Id
:= Current_Scope
;
9735 -- Start of processing for Make_Transient_Block
9738 -- Even though the transient block is tasked with managing the secondary
9739 -- stack, the block may forgo this functionality depending on how the
9740 -- secondary stack is managed by enclosing scopes.
9742 if Manages_Sec_Stack
(Trans_Id
) then
9744 -- Determine whether an enclosing scope already manages the secondary
9747 Scop
:= Scope
(Trans_Id
);
9748 while Present
(Scop
) loop
9750 -- It should not be possible to reach Standard without hitting one
9751 -- of the other cases first unless Standard was manually pushed.
9753 if Scop
= Standard_Standard
then
9756 -- The transient block is within a function which returns on the
9757 -- secondary stack. Take a conservative approach and assume that
9758 -- the value on the secondary stack is part of the result. Note
9759 -- that it is not possible to detect this dependency without flow
9760 -- analysis which the compiler does not have. Letting the object
9761 -- live longer than the transient block will not leak any memory
9762 -- because the caller will reclaim the total storage used by the
9765 elsif Ekind
(Scop
) = E_Function
9766 and then Sec_Stack_Needed_For_Return
(Scop
)
9768 Set_Uses_Sec_Stack
(Trans_Id
, False);
9771 -- The transient block must manage the secondary stack when the
9772 -- block appears within a loop in order to reclaim the memory at
9775 elsif Ekind
(Scop
) = E_Loop
then
9778 -- Ditto when the block appears without a block that does not
9779 -- manage the secondary stack and is located within a loop.
9781 elsif Ekind
(Scop
) = E_Block
9782 and then not Manages_Sec_Stack
(Scop
)
9783 and then Present
(Block_Node
(Scop
))
9784 and then Within_Loop_Statement
(Block_Node
(Scop
))
9788 -- The transient block does not need to manage the secondary stack
9789 -- when there is an enclosing construct which already does that.
9790 -- This optimization saves on SS_Mark and SS_Release calls but may
9791 -- allow objects to live a little longer than required.
9793 -- The transient block must manage the secondary stack when switch
9794 -- -gnatd.s (strict management) is in effect.
9796 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9797 Set_Uses_Sec_Stack
(Trans_Id
, False);
9800 -- Prevent the search from going too far because transient blocks
9801 -- are bounded by packages and subprogram scopes.
9803 elsif Ekind
(Scop
) in E_Entry
9813 Scop
:= Scope
(Scop
);
9817 -- Create the transient block. Set the parent now since the block itself
9818 -- is not part of the tree. The current scope is the E_Block entity that
9819 -- has been pushed by Establish_Transient_Scope.
9821 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9824 Make_Block_Statement
(Loc
,
9825 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9826 Declarations
=> Decls
,
9827 Handled_Statement_Sequence
=>
9828 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9829 Has_Created_Identifier
=> True);
9830 Set_Parent
(Block
, Par
);
9832 -- Insert actions stuck in the transient scopes as well as all freezing
9833 -- nodes needed by those actions. Do not insert cleanup actions here,
9834 -- they will be transferred to the newly created block.
9836 Insert_Actions_In_Scope_Around
9837 (Action
, Clean
=> False, Manage_SS
=> False);
9839 Insert
:= Prev
(Action
);
9841 if Present
(Insert
) then
9842 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9845 -- Transfer cleanup actions to the newly created block
9848 Cleanup_Actions
: List_Id
9849 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9850 Actions_To_Be_Wrapped
(Cleanup
);
9852 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9853 Cleanup_Actions
:= No_List
;
9856 -- When the transient scope was established, we pushed the entry for the
9857 -- transient scope onto the scope stack, so that the scope was active
9858 -- for the installation of finalizable entities etc. Now we must remove
9859 -- this entry, since we have constructed a proper block.
9864 end Make_Transient_Block
;
9866 ------------------------
9867 -- Node_To_Be_Wrapped --
9868 ------------------------
9870 function Node_To_Be_Wrapped
return Node_Id
is
9872 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9873 end Node_To_Be_Wrapped
;
9875 ----------------------------
9876 -- Store_Actions_In_Scope --
9877 ----------------------------
9879 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9880 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9881 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9884 if Is_Empty_List
(Actions
) then
9887 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9888 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9890 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9895 elsif AK
= Before
then
9896 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9899 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9901 end Store_Actions_In_Scope
;
9903 ----------------------------------
9904 -- Store_After_Actions_In_Scope --
9905 ----------------------------------
9907 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9909 Store_Actions_In_Scope
(After
, L
);
9910 end Store_After_Actions_In_Scope
;
9912 -----------------------------------
9913 -- Store_Before_Actions_In_Scope --
9914 -----------------------------------
9916 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9918 Store_Actions_In_Scope
(Before
, L
);
9919 end Store_Before_Actions_In_Scope
;
9921 -----------------------------------
9922 -- Store_Cleanup_Actions_In_Scope --
9923 -----------------------------------
9925 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9927 Store_Actions_In_Scope
(Cleanup
, L
);
9928 end Store_Cleanup_Actions_In_Scope
;
9934 procedure Unnest_Block
(Decl
: Node_Id
) is
9935 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9937 Local_Body
: Node_Id
;
9938 Local_Call
: Node_Id
;
9939 Local_Proc
: Entity_Id
;
9940 Local_Scop
: Entity_Id
;
9943 Local_Scop
:= Entity
(Identifier
(Decl
));
9944 Ent
:= First_Entity
(Local_Scop
);
9946 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9949 Make_Subprogram_Body
(Loc
,
9951 Make_Procedure_Specification
(Loc
,
9952 Defining_Unit_Name
=> Local_Proc
),
9953 Declarations
=> Declarations
(Decl
),
9954 Handled_Statement_Sequence
=>
9955 Handled_Statement_Sequence
(Decl
));
9957 -- Handlers in the block may contain nested subprograms that require
9960 Check_Unnesting_In_Handlers
(Local_Body
);
9962 Rewrite
(Decl
, Local_Body
);
9964 Set_Has_Nested_Subprogram
(Local_Proc
);
9967 Make_Procedure_Call_Statement
(Loc
,
9968 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9970 Insert_After
(Decl
, Local_Call
);
9971 Analyze
(Local_Call
);
9973 -- The new subprogram has the same scope as the original block
9975 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9977 -- And the entity list of the new procedure is that of the block
9979 Set_First_Entity
(Local_Proc
, Ent
);
9981 -- Reset the scopes of all the entities to the new procedure
9983 while Present
(Ent
) loop
9984 Set_Scope
(Ent
, Local_Proc
);
9989 -------------------------
9990 -- Unnest_If_Statement --
9991 -------------------------
9993 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
9995 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
9996 -- A list of statements (that may be a list associated with a then,
9997 -- elsif, or else part of an if-statement) is traversed at the top
9998 -- level to determine whether it contains a subprogram body, and if so,
9999 -- the statements will be replaced with a new procedure body containing
10000 -- the statements followed by a call to the procedure. The individual
10001 -- statements may also be blocks, loops, or other if statements that
10002 -- themselves may require contain nested subprograms needing unnesting.
10004 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
10005 Subp_Found
: Boolean := False;
10008 if Is_Empty_List
(Stmts
) then
10013 Stmt
: Node_Id
:= First
(Stmts
);
10015 while Present
(Stmt
) loop
10016 if Nkind
(Stmt
) = N_Subprogram_Body
then
10017 Subp_Found
:= True;
10025 -- The statements themselves may be blocks, loops, etc. that in turn
10026 -- contain nested subprograms requiring an unnesting transformation.
10027 -- We perform this traversal after looking for subprogram bodies, to
10028 -- avoid considering procedures created for one of those statements
10029 -- (such as a block rewritten as a procedure) as a nested subprogram
10030 -- of the statement list (which could result in an unneeded wrapper
10033 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
10035 -- If there was a top-level subprogram body in the statement list,
10036 -- then perform an unnesting transformation on the list by replacing
10037 -- the statements with a wrapper procedure body containing the
10038 -- original statements followed by a call to that procedure.
10041 Unnest_Statement_List
(Stmts
);
10043 end Check_Stmts_For_Subp_Unnesting
;
10047 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
10048 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
10050 -- Start of processing for Unnest_If_Statement
10053 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
10054 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
10056 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
10058 Elsif_Part
: Node_Id
:=
10059 First
(Elsif_Parts
(If_Stmt
));
10060 Elsif_Stmts
: List_Id
;
10062 while Present
(Elsif_Part
) loop
10063 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
10065 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
10066 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
10073 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
10074 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
10075 end Unnest_If_Statement
;
10081 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
10082 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
10084 Local_Body
: Node_Id
;
10085 Local_Call
: Node_Id
;
10086 Local_Proc
: Entity_Id
;
10087 Local_Scop
: Entity_Id
;
10088 Loop_Copy
: constant Node_Id
:=
10089 Relocate_Node
(Loop_Stmt
);
10091 Local_Scop
:= Entity
(Identifier
(Loop_Stmt
));
10092 Ent
:= First_Entity
(Local_Scop
);
10094 Local_Proc
:= Make_Temporary
(Loc
, 'P');
10097 Make_Subprogram_Body
(Loc
,
10099 Make_Procedure_Specification
(Loc
,
10100 Defining_Unit_Name
=> Local_Proc
),
10101 Declarations
=> Empty_List
,
10102 Handled_Statement_Sequence
=>
10103 Make_Handled_Sequence_Of_Statements
(Loc
,
10104 Statements
=> New_List
(Loop_Copy
)));
10106 Set_First_Real_Statement
10107 (Handled_Statement_Sequence
(Local_Body
), Loop_Copy
);
10109 Rewrite
(Loop_Stmt
, Local_Body
);
10110 Analyze
(Loop_Stmt
);
10112 Set_Has_Nested_Subprogram
(Local_Proc
);
10115 Make_Procedure_Call_Statement
(Loc
,
10116 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
10118 Insert_After
(Loop_Stmt
, Local_Call
);
10119 Analyze
(Local_Call
);
10121 -- New procedure has the same scope as the original loop, and the scope
10122 -- of the loop is the new procedure.
10124 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
10125 Set_Scope
(Local_Scop
, Local_Proc
);
10127 -- The entity list of the new procedure is that of the loop
10129 Set_First_Entity
(Local_Proc
, Ent
);
10131 -- Note that the entities associated with the loop don't need to have
10132 -- their Scope fields reset, since they're still associated with the
10133 -- same loop entity that now belongs to the copied loop statement.
10136 ---------------------------
10137 -- Unnest_Statement_List --
10138 ---------------------------
10140 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
10141 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
10142 Local_Body
: Node_Id
;
10143 Local_Call
: Node_Id
;
10144 Local_Proc
: Entity_Id
;
10145 New_Stmts
: constant List_Id
:= Empty_List
;
10148 Local_Proc
:= Make_Temporary
(Loc
, 'P');
10151 Make_Subprogram_Body
(Loc
,
10153 Make_Procedure_Specification
(Loc
,
10154 Defining_Unit_Name
=> Local_Proc
),
10155 Declarations
=> Empty_List
,
10156 Handled_Statement_Sequence
=>
10157 Make_Handled_Sequence_Of_Statements
(Loc
,
10158 Statements
=> Stmts
));
10160 Append_To
(New_Stmts
, Local_Body
);
10162 Analyze
(Local_Body
);
10164 Set_Has_Nested_Subprogram
(Local_Proc
);
10167 Make_Procedure_Call_Statement
(Loc
,
10168 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
10170 Append_To
(New_Stmts
, Local_Call
);
10171 Analyze
(Local_Call
);
10173 -- Traverse the statements, and for any that are declarations or
10174 -- subprogram bodies that have entities, set the Scope of those
10175 -- entities to the new procedure's Entity_Id.
10178 Stmt
: Node_Id
:= First
(Stmts
);
10181 while Present
(Stmt
) loop
10182 case Nkind
(Stmt
) is
10184 | N_Renaming_Declaration
10186 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
10188 when N_Subprogram_Body
=>
10190 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
10200 Stmts
:= New_Stmts
;
10201 end Unnest_Statement_List
;
10203 --------------------------------
10204 -- Wrap_Transient_Declaration --
10205 --------------------------------
10207 -- If a transient scope has been established during the processing of the
10208 -- Expression of an Object_Declaration, it is not possible to wrap the
10209 -- declaration into a transient block as usual case, otherwise the object
10210 -- would be itself declared in the wrong scope. Therefore, all entities (if
10211 -- any) defined in the transient block are moved to the proper enclosing
10212 -- scope. Furthermore, if they are controlled variables they are finalized
10213 -- right after the declaration. The finalization list of the transient
10214 -- scope is defined as a renaming of the enclosing one so during their
10215 -- initialization they will be attached to the proper finalization list.
10216 -- For instance, the following declaration :
10218 -- X : Typ := F (G (A), G (B));
10220 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
10221 -- is expanded into :
10223 -- X : Typ := [ complex Expression-Action ];
10224 -- [Deep_]Finalize (_v1);
10225 -- [Deep_]Finalize (_v2);
10227 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
10228 Curr_S
: Entity_Id
;
10229 Encl_S
: Entity_Id
;
10232 Curr_S
:= Current_Scope
;
10233 Encl_S
:= Scope
(Curr_S
);
10235 -- Insert all actions including cleanup generated while analyzing or
10236 -- expanding the transient context back into the tree. Manage the
10237 -- secondary stack when the object declaration appears in a library
10238 -- level package [body].
10240 Insert_Actions_In_Scope_Around
10244 Uses_Sec_Stack
(Curr_S
)
10245 and then Nkind
(N
) = N_Object_Declaration
10246 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
10247 and then Is_Library_Level_Entity
(Encl_S
));
10250 -- Relocate local entities declared within the transient scope to the
10251 -- enclosing scope. This action sets their Is_Public flag accordingly.
10253 Transfer_Entities
(Curr_S
, Encl_S
);
10255 -- Mark the enclosing dynamic scope to ensure that the secondary stack
10256 -- is properly released upon exiting the said scope.
10258 if Uses_Sec_Stack
(Curr_S
) then
10259 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
10261 -- Do not mark a function that returns on the secondary stack as the
10262 -- reclamation is done by the caller.
10264 if Ekind
(Curr_S
) = E_Function
10265 and then Needs_Secondary_Stack
(Etype
(Curr_S
))
10269 -- Otherwise mark the enclosing dynamic scope
10272 Set_Uses_Sec_Stack
(Curr_S
);
10273 Check_Restriction
(No_Secondary_Stack
, N
);
10276 end Wrap_Transient_Declaration
;
10278 -------------------------------
10279 -- Wrap_Transient_Expression --
10280 -------------------------------
10282 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
10283 Loc
: constant Source_Ptr
:= Sloc
(N
);
10284 Expr
: Node_Id
:= Relocate_Node
(N
);
10285 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
10286 Typ
: constant Entity_Id
:= Etype
(N
);
10293 -- M : constant Mark_Id := SS_Mark;
10294 -- procedure Finalizer is ... (See Build_Finalizer)
10297 -- Temp := <Expr>; -- general case
10298 -- Temp := (if <Expr> then True else False); -- boolean case
10304 -- A special case is made for Boolean expressions so that the back end
10305 -- knows to generate a conditional branch instruction, if running with
10306 -- -fpreserve-control-flow. This ensures that a control-flow change
10307 -- signaling the decision outcome occurs before the cleanup actions.
10309 if Opt
.Suppress_Control_Flow_Optimizations
10310 and then Is_Boolean_Type
(Typ
)
10313 Make_If_Expression
(Loc
,
10314 Expressions
=> New_List
(
10316 New_Occurrence_Of
(Standard_True
, Loc
),
10317 New_Occurrence_Of
(Standard_False
, Loc
)));
10320 Insert_Actions
(N
, New_List
(
10321 Make_Object_Declaration
(Loc
,
10322 Defining_Identifier
=> Temp
,
10323 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
10325 Make_Transient_Block
(Loc
,
10327 Make_Assignment_Statement
(Loc
,
10328 Name
=> New_Occurrence_Of
(Temp
, Loc
),
10329 Expression
=> Expr
),
10330 Par
=> Parent
(N
))));
10332 if Debug_Generated_Code
then
10333 Set_Debug_Info_Needed
(Temp
);
10336 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
10337 Analyze_And_Resolve
(N
, Typ
);
10338 end Wrap_Transient_Expression
;
10340 ------------------------------
10341 -- Wrap_Transient_Statement --
10342 ------------------------------
10344 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
10345 Loc
: constant Source_Ptr
:= Sloc
(N
);
10346 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
10351 -- M : constant Mark_Id := SS_Mark;
10352 -- procedure Finalizer is ... (See Build_Finalizer)
10362 Make_Transient_Block
(Loc
,
10363 Action
=> New_Stmt
,
10364 Par
=> Parent
(N
)));
10366 -- With the scope stack back to normal, we can call analyze on the
10367 -- resulting block. At this point, the transient scope is being
10368 -- treated like a perfectly normal scope, so there is nothing
10369 -- special about it.
10371 -- Note: Wrap_Transient_Statement is called with the node already
10372 -- analyzed (i.e. Analyzed (N) is True). This is important, since
10373 -- otherwise we would get a recursive processing of the node when
10374 -- we do this Analyze call.
10377 end Wrap_Transient_Statement
;