1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Einfo
.Entities
; use Einfo
.Entities
;
34 with Einfo
.Utils
; use Einfo
.Utils
;
35 with Elists
; use Elists
;
36 with Errout
; use Errout
;
37 with Exp_Ch6
; use Exp_Ch6
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Ch11
; use Exp_Ch11
;
40 with Exp_Dbug
; use Exp_Dbug
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Disp
; use Exp_Disp
;
43 with Exp_Prag
; use Exp_Prag
;
44 with Exp_Tss
; use Exp_Tss
;
45 with Exp_Util
; use Exp_Util
;
46 with Freeze
; use Freeze
;
47 with GNAT_CUDA
; use GNAT_CUDA
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Output
; use Output
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
58 with Sinfo
.Utils
; use Sinfo
.Utils
;
60 with Sem_Aux
; use Sem_Aux
;
61 with Sem_Ch7
; use Sem_Ch7
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Snames
; use Snames
;
66 with Stand
; use Stand
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Uintp
; use Uintp
;
71 package body Exp_Ch7
is
73 -----------------------------
74 -- Finalization Management --
75 -----------------------------
77 -- This part describes how Initialization/Adjustment/Finalization
78 -- procedures are generated and called. Two cases must be considered: types
79 -- that are Controlled (Is_Controlled flag set) and composite types that
80 -- contain controlled components (Has_Controlled_Component flag set). In
81 -- the first case the procedures to call are the user-defined primitive
82 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
83 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
84 -- charge of calling the former procedures on the controlled components.
86 -- For records with Has_Controlled_Component set, a hidden "controller"
87 -- component is inserted. This controller component contains its own
88 -- finalization list on which all controlled components are attached
89 -- creating an indirection on the upper-level Finalization list. This
90 -- technique facilitates the management of objects whose number of
91 -- controlled components changes during execution. This controller
92 -- component is itself controlled and is attached to the upper-level
93 -- finalization chain. Its adjust primitive is in charge of calling adjust
94 -- on the components and adjusting the finalization pointer to match their
95 -- new location (see a-finali.adb).
97 -- It is not possible to use a similar technique for arrays that have
98 -- Has_Controlled_Component set. In this case, deep procedures are
99 -- generated that call initialize/adjust/finalize + attachment or
100 -- detachment on the finalization list for all component.
102 -- Initialize calls: they are generated for declarations or dynamic
103 -- allocations of Controlled objects with no initial value. They are always
104 -- followed by an attachment to the current Finalization Chain. For the
105 -- dynamic allocation case this the chain attached to the scope of the
106 -- access type definition otherwise, this is the chain of the current
109 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
110 -- or dynamic allocations of Controlled objects with an initial value.
111 -- (2) after an assignment. In the first case they are followed by an
112 -- attachment to the final chain, in the second case they are not.
114 -- Finalization Calls: They are generated on (1) scope exit, (2)
115 -- assignments, (3) unchecked deallocations. In case (3) they have to
116 -- be detached from the final chain, in case (2) they must not and in
117 -- case (1) this is not important since we are exiting the scope anyway.
121 -- Type extensions will have a new record controller at each derivation
122 -- level containing controlled components. The record controller for
123 -- the parent/ancestor is attached to the finalization list of the
124 -- extension's record controller (i.e. the parent is like a component
125 -- of the extension).
127 -- For types that are both Is_Controlled and Has_Controlled_Components,
128 -- the record controller and the object itself are handled separately.
129 -- It could seem simpler to attach the object at the end of its record
130 -- controller but this would not tackle view conversions properly.
132 -- A classwide type can always potentially have controlled components
133 -- but the record controller of the corresponding actual type may not
134 -- be known at compile time so the dispatch table contains a special
135 -- field that allows computation of the offset of the record controller
136 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
138 -- Here is a simple example of the expansion of a controlled block :
142 -- Y : Controlled := Init;
148 -- Z : R := (C => X);
158 -- _L : System.FI.Finalizable_Ptr;
160 -- procedure _Clean is
163 -- System.FI.Finalize_List (_L);
171 -- Attach_To_Final_List (_L, Finalizable (X), 1);
172 -- at end: Abort_Undefer;
173 -- Y : Controlled := Init;
175 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
183 -- Deep_Initialize (W, _L, 1);
184 -- at end: Abort_Under;
185 -- Z : R := (C => X);
186 -- Deep_Adjust (Z, _L, 1);
190 -- Deep_Finalize (W, False);
191 -- <save W's final pointers>
193 -- <restore W's final pointers>
194 -- Deep_Adjust (W, _L, 0);
199 type Final_Primitives
is
200 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
201 -- This enumeration type is defined in order to ease sharing code for
202 -- building finalization procedures for composite types.
204 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
205 (Initialize_Case
=> Name_Initialize
,
206 Adjust_Case
=> Name_Adjust
,
207 Finalize_Case
=> Name_Finalize
,
208 Address_Case
=> Name_Finalize_Address
);
209 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
210 (Initialize_Case
=> TSS_Deep_Initialize
,
211 Adjust_Case
=> TSS_Deep_Adjust
,
212 Finalize_Case
=> TSS_Deep_Finalize
,
213 Address_Case
=> TSS_Finalize_Address
);
215 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
216 -- Determine whether access type Typ may have a finalization master
218 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
219 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
220 -- Has_Controlled_Component set and store them using the TSS mechanism.
222 function Build_Cleanup_Statements
224 Additional_Cleanup
: List_Id
) return List_Id
;
225 -- Create the cleanup calls for an asynchronous call block, task master,
226 -- protected subprogram body, task allocation block or task body, or
227 -- additional cleanup actions parked on a transient block. If the context
228 -- does not contain the above constructs, the routine returns an empty
231 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
232 -- N is a construct that contains a handled sequence of statements, Fin_Id
233 -- is the entity of a finalizer. Create an At_End handler that covers the
234 -- statements of N and calls Fin_Id. If the handled statement sequence has
235 -- an exception handler, the statements will be wrapped in a block to avoid
236 -- unwanted interaction with the new At_End handler.
238 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
239 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
240 -- Has_Component_Component set and store them using the TSS mechanism.
242 --------------------------------
243 -- Transient Scope Management --
244 --------------------------------
246 -- A transient scope is needed when certain temporary objects are created
247 -- by the compiler. These temporary objects are allocated on the secondary
248 -- stack and/or need finalization, and the transient scope is responsible
249 -- for finalizing the objects and reclaiming the memory of the secondary
250 -- stack at the appropriate time. They are generally objects allocated to
251 -- store the result of a function returning an unconstrained or controlled
252 -- value. Expressions needing to be wrapped in a transient scope may appear
253 -- in three different contexts, which lead to different kinds of transient
256 -- 1. In a simple statement (procedure call, assignment, ...). In this
257 -- case the statement is wrapped into a transient block, which takes
258 -- care of the finalization actions as well as the secondary stack
259 -- deallocation, See Wrap_Transient_Statement for details.
261 -- 2. In an expression of a control structure (test in a If statement,
262 -- expression in a Case statement, ...). In this case the expression
263 -- is replaced by a temporary and the enclosing statement is wrapped
264 -- into a transient block, which takes care of the finalization actions
265 -- and the secondary stack deallocation. See Wrap_Transient_Expression
268 -- 3. In an expression of an object declaration. No wrapping is possible
269 -- here, so the finalization actions performed on the normal path, if
270 -- any, are done right after the declaration, and those performed on
271 -- the exceptional path, as well as the secondary stack deallocation,
272 -- are deferred to the enclosing scope. See Wrap_Transient_Declaration
275 -- A transient scope is created by calling Establish_Transient_Scope on the
276 -- node that needs to be serviced by it (the serviced node can subsequently
277 -- be retrieved by invoking Node_To_Be_Wrapped when the current scope is a
278 -- transient scope). Once this has been done, the normal processing of the
279 -- Insert_Actions procedures is blocked and the procedures are redirected
280 -- to the Store_xxx_Actions_In_Scope procedures and Store_Actions_In_Scope
281 -- is ultimately invoked to store the pending actions.
283 -- A transient scope is finalized by calling one of the Wrap_Transient_xxx
284 -- procedures depending on the context as explained above. They ultimately
285 -- invoke Insert_Actions_In_Scope_Around as per the following picture:
287 -- Wrap_Transient_Expression Wrap_Transient_Statement
290 -- Make_Transient_Block
292 -- Wrap_Transient_Declaration |
295 -- Insert_Actions_In_Scope_Around
297 procedure Insert_Actions_In_Scope_Around
300 Manage_SS
: Boolean);
301 -- Insert the before-actions kept in the scope stack before N, and the
302 -- after-actions after N, which must be a member of a list. If Clean is
303 -- true, insert any cleanup actions kept in the scope stack and generate
304 -- required finalization actions for the before-actions and after-actions.
305 -- If Manage_SS is true, insert calls to mark/release the secondary stack.
307 function Make_Transient_Block
310 Par
: Node_Id
) return Node_Id
;
311 -- Action is a single statement or object declaration. Par is the proper
312 -- parent of the generated block. Create a transient block whose name is
313 -- the current scope and the only handled statement is Action. If Action
314 -- involves controlled objects or secondary stack usage, the corresponding
315 -- cleanup actions are performed at the end of the block.
317 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
318 -- Shared processing for Store_xxx_Actions_In_Scope
320 -------------------------------------------
321 -- Unnesting procedures for CCG and LLVM --
322 -------------------------------------------
324 -- Expansion generates subprograms for controlled types management that
325 -- may appear in declarative lists in package declarations and bodies.
326 -- These subprograms appear within generated blocks that contain local
327 -- declarations and a call to finalization procedures. To ensure that
328 -- such subprograms get activation records when needed, we transform the
329 -- block into a procedure body, followed by a call to it in the same
332 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
333 -- The statement part of a package body that is a compilation unit may
334 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
335 -- Mode such subprograms must be handled as nested inside the (implicit)
336 -- elaboration procedure that executes that statement part. To handle
337 -- properly uplevel references we construct that subprogram explicitly,
338 -- to contain blocks and inner subprograms, the statement part becomes
339 -- a call to this subprogram. This is only done if blocks are present
340 -- in the statement list of the body. (It would be nice to unify this
341 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
342 -- they're doing very similar work, but are structured differently. ???)
344 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
345 -- Similarly, the declarations or statements in library-level packages may
346 -- have created blocks with nested subprograms. Such a block must be
347 -- transformed into a procedure followed by a call to it, so that unnesting
348 -- can handle uplevel references within these nested subprograms (typically
349 -- subprograms that handle finalization actions). This also applies to
350 -- nested packages, including instantiations, in which case it must
351 -- recursively process inner bodies.
353 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
354 -- Similarly, check for blocks with nested subprograms occurring within
355 -- a set of exception handlers associated with a package body N.
357 procedure Unnest_Block
(Decl
: Node_Id
);
358 -- Blocks that contain nested subprograms with up-level references need to
359 -- create activation records for them. We do this by rewriting the block as
360 -- a procedure, followed by a call to it in the same declarative list, to
361 -- replicate the semantics of the original block.
363 -- A common source for such block is a transient block created for a
364 -- construct (declaration, assignment, etc.) that involves controlled
365 -- actions or secondary-stack management, in which case the nested
366 -- subprogram is a finalizer.
368 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
369 -- The separate statement lists associated with an if-statement (then part,
370 -- elsif parts, else part) may require unnesting if they directly contain
371 -- a subprogram body that references up-level objects. Each statement list
372 -- is traversed to locate such subprogram bodies, and if a part's statement
373 -- list contains a body, then the list is replaced with a new procedure
374 -- containing the part's statements followed by a call to the procedure.
375 -- Furthermore, any nested blocks, loops, or if statements will also be
376 -- traversed to determine the need for further unnesting transformations.
378 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
379 -- A list of statements that directly contains a subprogram at its outer
380 -- level, that may reference objects declared in that same statement list,
381 -- is rewritten as a procedure containing the statement list Stmts (which
382 -- includes any such objects as well as the nested subprogram), followed by
383 -- a call to the new procedure, and Stmts becomes the list containing the
384 -- procedure and the call. This ensures that Unnest_Subprogram will later
385 -- properly handle up-level references from the nested subprogram to
386 -- objects declared earlier in statement list, by creating an activation
387 -- record and passing it to the nested subprogram. This procedure also
388 -- resets the Scope of objects declared in the statement list, as well as
389 -- the Scope of the nested subprogram, to refer to the new procedure.
390 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
391 -- only be called when known that the statement list contains a subprogram.
393 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
394 -- Top-level Loops that contain nested subprograms with up-level references
395 -- need to have activation records. We do this by rewriting the loop as a
396 -- procedure containing the loop, followed by a call to the procedure in
397 -- the same library-level declarative list, to replicate the semantics of
398 -- the original loop. Such loops can occur due to aggregate expansions and
401 procedure Check_Visibly_Controlled
402 (Prim
: Final_Primitives
;
404 E
: in out Entity_Id
;
405 Cref
: in out Node_Id
);
406 -- The controlled operation declared for a derived type may not be
407 -- overriding, if the controlled operations of the parent type are hidden,
408 -- for example when the parent is a private type whose full view is
409 -- controlled. For other primitive operations we modify the name of the
410 -- operation to indicate that it is not overriding, but this is not
411 -- possible for Initialize, etc. because they have to be retrievable by
412 -- name. Before generating the proper call to one of these operations we
413 -- check whether Typ is known to be controlled at the point of definition.
414 -- If it is not then we must retrieve the hidden operation of the parent
415 -- and use it instead. This is one case that might be solved more cleanly
416 -- once Overriding pragmas or declarations are in place.
418 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
419 -- Check recursively whether a loop or block contains a subprogram that
420 -- may need an activation record.
422 function Convert_View
(Proc
: Entity_Id
; Arg
: Node_Id
) return Node_Id
;
423 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
424 -- argument being passed to it. This function will, if necessary, generate
425 -- a conversion between the partial and full view of Arg to match the type
426 -- of the formal of Proc, or force a conversion to the class-wide type in
427 -- the case where the operation is abstract.
433 Skip_Self
: Boolean := False) return Node_Id
;
434 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
435 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
436 -- an adjust or finalization call. When flag Skip_Self is set, the related
437 -- action has an effect on the components only (if any).
439 function Make_Deep_Proc
440 (Prim
: Final_Primitives
;
442 Stmts
: List_Id
) return Entity_Id
;
443 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
444 -- Deep_Finalize procedures according to the first parameter. These
445 -- procedures operate on the type Typ. The Stmts parameter gives the
446 -- body of the procedure.
448 function Make_Deep_Array_Body
449 (Prim
: Final_Primitives
;
450 Typ
: Entity_Id
) return List_Id
;
451 -- This function generates the list of statements for implementing
452 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
453 -- the first parameter, these procedures operate on the array type Typ.
455 function Make_Deep_Record_Body
456 (Prim
: Final_Primitives
;
458 Is_Local
: Boolean := False) return List_Id
;
459 -- This function generates the list of statements for implementing
460 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
461 -- the first parameter, these procedures operate on the record type Typ.
462 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
463 -- whether the inner logic should be dictated by state counters.
465 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
466 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
467 -- Make_Deep_Record_Body. Generate the following statements:
470 -- type Acc_Typ is access all Typ;
471 -- for Acc_Typ'Storage_Size use 0;
473 -- [Deep_]Finalize (Acc_Typ (V).all);
476 --------------------------------
477 -- Allows_Finalization_Master --
478 --------------------------------
480 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
481 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
482 -- Determine whether entity E is inside a wrapper package created for
483 -- an instance of Ada.Unchecked_Deallocation.
485 ------------------------------
486 -- In_Deallocation_Instance --
487 ------------------------------
489 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
490 Pkg
: constant Entity_Id
:= Scope
(E
);
491 Par
: Node_Id
:= Empty
;
494 if Ekind
(Pkg
) = E_Package
495 and then Present
(Related_Instance
(Pkg
))
496 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
498 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
502 and then Chars
(Par
) = Name_Unchecked_Deallocation
503 and then Chars
(Scope
(Par
)) = Name_Ada
504 and then Scope
(Scope
(Par
)) = Standard_Standard
;
508 end In_Deallocation_Instance
;
512 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
513 Ptr_Typ
: constant Entity_Id
:=
514 Root_Type_Of_Full_View
(Base_Type
(Typ
));
516 -- Start of processing for Allows_Finalization_Master
519 -- Certain run-time configurations and targets do not provide support
520 -- for controlled types and therefore do not need masters.
522 if Restriction_Active
(No_Finalization
) then
525 -- Do not consider C and C++ types since it is assumed that the non-Ada
526 -- side will handle their cleanup.
528 elsif Convention
(Desig_Typ
) = Convention_C
529 or else Convention
(Desig_Typ
) = Convention_CPP
533 -- Do not consider an access type that returns on the secondary stack
535 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
536 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
540 -- Do not consider an access type that can never allocate an object
542 elsif No_Pool_Assigned
(Ptr_Typ
) then
545 -- Do not consider an access type coming from an Unchecked_Deallocation
546 -- instance. Even though the designated type may be controlled, the
547 -- access type will never participate in any allocations.
549 elsif In_Deallocation_Instance
(Ptr_Typ
) then
552 -- Do not consider a non-library access type when No_Nested_Finalization
553 -- is in effect since finalization masters are controlled objects and if
554 -- created will violate the restriction.
556 elsif Restriction_Active
(No_Nested_Finalization
)
557 and then not Is_Library_Level_Entity
(Ptr_Typ
)
561 -- Do not consider an access type subject to pragma No_Heap_Finalization
562 -- because objects allocated through such a type are not to be finalized
563 -- when the access type goes out of scope.
565 elsif No_Heap_Finalization
(Ptr_Typ
) then
568 -- Do not create finalization masters in GNATprove mode because this
569 -- causes unwanted extra expansion. A compilation in this mode must
570 -- keep the tree as close as possible to the original sources.
572 elsif GNATprove_Mode
then
575 -- Otherwise the access type may use a finalization master
580 end Allows_Finalization_Master
;
582 ----------------------------
583 -- Build_Anonymous_Master --
584 ----------------------------
586 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
587 function Create_Anonymous_Master
588 (Desig_Typ
: Entity_Id
;
590 Unit_Decl
: Node_Id
) return Entity_Id
;
591 -- Create a new anonymous master for access type Ptr_Typ with designated
592 -- type Desig_Typ. The declaration of the master and its initialization
593 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
594 -- the entity of Unit_Decl.
596 function Current_Anonymous_Master
597 (Desig_Typ
: Entity_Id
;
598 Unit_Id
: Entity_Id
) return Entity_Id
;
599 -- Find an anonymous master declared within unit Unit_Id which services
600 -- designated type Desig_Typ. If there is no such master, return Empty.
602 -----------------------------
603 -- Create_Anonymous_Master --
604 -----------------------------
606 function Create_Anonymous_Master
607 (Desig_Typ
: Entity_Id
;
609 Unit_Decl
: Node_Id
) return Entity_Id
611 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
622 -- <FM_Id> : Finalization_Master;
624 FM_Id
:= Make_Temporary
(Loc
, 'A');
627 Make_Object_Declaration
(Loc
,
628 Defining_Identifier
=> FM_Id
,
630 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
634 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
637 Make_Procedure_Call_Statement
(Loc
,
639 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
640 Parameter_Associations
=> New_List
(
641 New_Occurrence_Of
(FM_Id
, Loc
),
642 Make_Attribute_Reference
(Loc
,
644 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
645 Attribute_Name
=> Name_Unrestricted_Access
)));
647 -- Find the declarative list of the unit
649 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
650 Unit_Spec
:= Specification
(Unit_Decl
);
651 Decls
:= Visible_Declarations
(Unit_Spec
);
655 Set_Visible_Declarations
(Unit_Spec
, Decls
);
658 -- Package body or subprogram case
660 -- ??? A subprogram spec or body that acts as a compilation unit may
661 -- contain a formal parameter of an anonymous access-to-controlled
662 -- type initialized by an allocator.
664 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
666 -- There is no suitable place to create the master as the subprogram
667 -- is not in a declarative list.
670 Decls
:= Declarations
(Unit_Decl
);
674 Set_Declarations
(Unit_Decl
, Decls
);
678 Prepend_To
(Decls
, FM_Init
);
679 Prepend_To
(Decls
, FM_Decl
);
681 -- Use the scope of the unit when analyzing the declaration of the
682 -- master and its initialization actions.
684 Push_Scope
(Unit_Id
);
689 -- Mark the master as servicing this specific designated type
691 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
693 -- Include the anonymous master in the list of existing masters which
694 -- appear in this unit. This effectively creates a mapping between a
695 -- master and a designated type which in turn allows for the reuse of
696 -- masters on a per-unit basis.
698 All_FMs
:= Anonymous_Masters
(Unit_Id
);
701 All_FMs
:= New_Elmt_List
;
702 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
705 Prepend_Elmt
(FM_Id
, All_FMs
);
708 end Create_Anonymous_Master
;
710 ------------------------------
711 -- Current_Anonymous_Master --
712 ------------------------------
714 function Current_Anonymous_Master
715 (Desig_Typ
: Entity_Id
;
716 Unit_Id
: Entity_Id
) return Entity_Id
718 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
723 -- Inspect the list of anonymous masters declared within the unit
724 -- looking for an existing master which services the same designated
727 if Present
(All_FMs
) then
728 FM_Elmt
:= First_Elmt
(All_FMs
);
729 while Present
(FM_Elmt
) loop
730 FM_Id
:= Node
(FM_Elmt
);
732 -- The currect master services the same designated type. As a
733 -- result the master can be reused and associated with another
734 -- anonymous access-to-controlled type.
736 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
745 end Current_Anonymous_Master
;
749 Desig_Typ
: Entity_Id
;
751 Priv_View
: Entity_Id
;
755 -- Start of processing for Build_Anonymous_Master
758 -- Nothing to do if the circumstances do not allow for a finalization
761 if not Allows_Finalization_Master
(Ptr_Typ
) then
765 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
766 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
768 -- The compilation unit is a package instantiation. In this case the
769 -- anonymous master is associated with the package spec as both the
770 -- spec and body appear at the same level.
772 if Nkind
(Unit_Decl
) = N_Package_Body
773 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
775 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
776 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
779 -- Use the initial declaration of the designated type when it denotes
780 -- the full view of an incomplete or private type. This ensures that
781 -- types with one and two views are treated the same.
783 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
784 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
786 if Present
(Priv_View
) then
787 Desig_Typ
:= Priv_View
;
790 -- Determine whether the current semantic unit already has an anonymous
791 -- master which services the designated type.
793 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
795 -- If this is not the case, create a new master
798 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
801 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
802 end Build_Anonymous_Master
;
804 ----------------------------
805 -- Build_Array_Deep_Procs --
806 ----------------------------
808 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
812 (Prim
=> Initialize_Case
,
814 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
816 if not Is_Inherently_Limited_Type
(Typ
) then
819 (Prim
=> Adjust_Case
,
821 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
824 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
825 -- suppressed since these routine will not be used.
827 if not Restriction_Active
(No_Finalization
) then
830 (Prim
=> Finalize_Case
,
832 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
834 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
836 if not CodePeer_Mode
then
839 (Prim
=> Address_Case
,
841 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
844 end Build_Array_Deep_Procs
;
846 ------------------------------
847 -- Build_Cleanup_Statements --
848 ------------------------------
850 function Build_Cleanup_Statements
852 Additional_Cleanup
: List_Id
) return List_Id
854 Is_Asynchronous_Call
: constant Boolean :=
855 Nkind
(N
) = N_Block_Statement
and then Is_Asynchronous_Call_Block
(N
);
856 Is_Master
: constant Boolean :=
857 Nkind
(N
) /= N_Entry_Body
and then Is_Task_Master
(N
);
858 Is_Protected_Subp_Body
: constant Boolean :=
859 Nkind
(N
) = N_Subprogram_Body
860 and then Is_Protected_Subprogram_Body
(N
);
861 Is_Task_Allocation
: constant Boolean :=
862 Nkind
(N
) = N_Block_Statement
and then Is_Task_Allocation_Block
(N
);
863 Is_Task_Body
: constant Boolean :=
864 Nkind
(Original_Node
(N
)) = N_Task_Body
;
866 Loc
: constant Source_Ptr
:= Sloc
(N
);
867 Stmts
: constant List_Id
:= New_List
;
871 if Restricted_Profile
then
873 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
875 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
879 if Restriction_Active
(No_Task_Hierarchy
) = False then
880 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
883 -- Add statements to unlock the protected object parameter and to
884 -- undefer abort. If the context is a protected procedure and the object
885 -- has entries, call the entry service routine.
887 -- NOTE: The generated code references _object, a parameter to the
890 elsif Is_Protected_Subp_Body
then
892 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
893 Conc_Typ
: Entity_Id
:= Empty
;
895 Param_Typ
: Entity_Id
;
898 -- Find the _object parameter representing the protected object
900 Param
:= First
(Parameter_Specifications
(Spec
));
902 Param_Typ
:= Etype
(Parameter_Type
(Param
));
904 if Ekind
(Param_Typ
) = E_Record_Type
then
905 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
908 exit when No
(Param
) or else Present
(Conc_Typ
);
912 pragma Assert
(Present
(Param
));
913 pragma Assert
(Present
(Conc_Typ
));
915 Build_Protected_Subprogram_Call_Cleanup
916 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
919 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
920 -- tasks. Other unactivated tasks are completed by Complete_Task or
923 -- NOTE: The generated code references _chain, a local object
925 elsif Is_Task_Allocation
then
928 -- Expunge_Unactivated_Tasks (_chain);
930 -- where _chain is the list of tasks created by the allocator but not
931 -- yet activated. This list will be empty unless the block completes
935 Make_Procedure_Call_Statement
(Loc
,
938 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
939 Parameter_Associations
=> New_List
(
940 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
942 -- Attempt to cancel an asynchronous entry call whenever the block which
943 -- contains the abortable part is exited.
945 -- NOTE: The generated code references Cnn, a local object
947 elsif Is_Asynchronous_Call
then
949 Cancel_Param
: constant Entity_Id
:=
950 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
953 -- If it is of type Communication_Block, this must be a protected
954 -- entry call. Generate:
956 -- if Enqueued (Cancel_Param) then
957 -- Cancel_Protected_Entry_Call (Cancel_Param);
960 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
962 Make_If_Statement
(Loc
,
964 Make_Function_Call
(Loc
,
966 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
967 Parameter_Associations
=> New_List
(
968 New_Occurrence_Of
(Cancel_Param
, Loc
))),
970 Then_Statements
=> New_List
(
971 Make_Procedure_Call_Statement
(Loc
,
974 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
975 Parameter_Associations
=> New_List
(
976 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
978 -- Asynchronous delay, generate:
979 -- Cancel_Async_Delay (Cancel_Param);
981 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
983 Make_Procedure_Call_Statement
(Loc
,
985 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
986 Parameter_Associations
=> New_List
(
987 Make_Attribute_Reference
(Loc
,
989 New_Occurrence_Of
(Cancel_Param
, Loc
),
990 Attribute_Name
=> Name_Unchecked_Access
))));
992 -- Task entry call, generate:
993 -- Cancel_Task_Entry_Call (Cancel_Param);
997 Make_Procedure_Call_Statement
(Loc
,
999 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
1000 Parameter_Associations
=> New_List
(
1001 New_Occurrence_Of
(Cancel_Param
, Loc
))));
1006 Append_List_To
(Stmts
, Additional_Cleanup
);
1008 end Build_Cleanup_Statements
;
1010 -----------------------------
1011 -- Build_Controlling_Procs --
1012 -----------------------------
1014 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
1016 if Is_Array_Type
(Typ
) then
1017 Build_Array_Deep_Procs
(Typ
);
1018 else pragma Assert
(Is_Record_Type
(Typ
));
1019 Build_Record_Deep_Procs
(Typ
);
1021 end Build_Controlling_Procs
;
1023 -----------------------------
1024 -- Build_Exception_Handler --
1025 -----------------------------
1027 function Build_Exception_Handler
1028 (Data
: Finalization_Exception_Data
;
1029 For_Library
: Boolean := False) return Node_Id
1032 Proc_To_Call
: Entity_Id
;
1037 pragma Assert
(Present
(Data
.Raised_Id
));
1039 if Exception_Extra_Info
1040 or else (For_Library
and not Restricted_Profile
)
1042 if Exception_Extra_Info
then
1046 -- Get_Current_Excep.all
1049 Make_Function_Call
(Data
.Loc
,
1051 Make_Explicit_Dereference
(Data
.Loc
,
1054 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1061 Except
:= Make_Null
(Data
.Loc
);
1064 if For_Library
and then not Restricted_Profile
then
1065 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1066 Actuals
:= New_List
(Except
);
1069 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1071 -- The dereference occurs only when Exception_Extra_Info is true,
1072 -- and therefore Except is not null.
1076 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1077 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1083 -- if not Raised_Id then
1084 -- Raised_Id := True;
1086 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1088 -- Save_Library_Occurrence (Get_Current_Excep.all);
1093 Make_If_Statement
(Data
.Loc
,
1095 Make_Op_Not
(Data
.Loc
,
1096 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1098 Then_Statements
=> New_List
(
1099 Make_Assignment_Statement
(Data
.Loc
,
1100 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1101 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1103 Make_Procedure_Call_Statement
(Data
.Loc
,
1105 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1106 Parameter_Associations
=> Actuals
))));
1111 -- Raised_Id := True;
1114 Make_Assignment_Statement
(Data
.Loc
,
1115 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1116 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1124 Make_Exception_Handler
(Data
.Loc
,
1125 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1126 Statements
=> Stmts
);
1127 end Build_Exception_Handler
;
1129 -------------------------------
1130 -- Build_Finalization_Master --
1131 -------------------------------
1133 procedure Build_Finalization_Master
1135 For_Lib_Level
: Boolean := False;
1136 For_Private
: Boolean := False;
1137 Context_Scope
: Entity_Id
:= Empty
;
1138 Insertion_Node
: Node_Id
:= Empty
)
1140 procedure Add_Pending_Access_Type
1142 Ptr_Typ
: Entity_Id
);
1143 -- Add access type Ptr_Typ to the pending access type list for type Typ
1145 -----------------------------
1146 -- Add_Pending_Access_Type --
1147 -----------------------------
1149 procedure Add_Pending_Access_Type
1151 Ptr_Typ
: Entity_Id
)
1156 if Present
(Pending_Access_Types
(Typ
)) then
1157 List
:= Pending_Access_Types
(Typ
);
1159 List
:= New_Elmt_List
;
1160 Set_Pending_Access_Types
(Typ
, List
);
1163 Prepend_Elmt
(Ptr_Typ
, List
);
1164 end Add_Pending_Access_Type
;
1168 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1170 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1171 -- A finalization master created for a named access type is associated
1172 -- with the full view (if applicable) as a consequence of freezing. The
1173 -- full view criteria does not apply to anonymous access types because
1174 -- those cannot have a private and a full view.
1176 -- Start of processing for Build_Finalization_Master
1179 -- Nothing to do if the circumstances do not allow for a finalization
1182 if not Allows_Finalization_Master
(Typ
) then
1185 -- Various machinery such as freezing may have already created a
1186 -- finalization master.
1188 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1193 Actions
: constant List_Id
:= New_List
;
1194 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1195 Fin_Mas_Id
: Entity_Id
;
1196 Pool_Id
: Entity_Id
;
1199 -- Source access types use fixed master names since the master is
1200 -- inserted in the same source unit only once. The only exception to
1201 -- this are instances using the same access type as generic actual.
1203 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1205 Make_Defining_Identifier
(Loc
,
1206 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1208 -- Internally generated access types use temporaries as their names
1209 -- due to possible collision with identical names coming from other
1213 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1216 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1219 -- <Ptr_Typ>FM : aliased Finalization_Master;
1222 Make_Object_Declaration
(Loc
,
1223 Defining_Identifier
=> Fin_Mas_Id
,
1224 Aliased_Present
=> True,
1225 Object_Definition
=>
1226 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1228 if Debug_Generated_Code
then
1229 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1232 -- Set the associated pool and primitive Finalize_Address of the new
1233 -- finalization master.
1235 -- The access type has a user-defined storage pool, use it
1237 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1238 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1240 -- Otherwise the default choice is the global storage pool
1243 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1244 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1248 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1251 Make_Procedure_Call_Statement
(Loc
,
1253 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1254 Parameter_Associations
=> New_List
(
1255 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1256 Make_Attribute_Reference
(Loc
,
1257 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1258 Attribute_Name
=> Name_Unrestricted_Access
))));
1260 -- Finalize_Address is not generated in CodePeer mode because the
1261 -- body contains address arithmetic. Skip this step.
1263 if CodePeer_Mode
then
1266 -- Associate the Finalize_Address primitive of the designated type
1267 -- with the finalization master of the access type. The designated
1268 -- type must be frozen, as Finalize_Address is generated when the
1269 -- freeze node is expanded.
1271 elsif Is_Frozen
(Desig_Typ
)
1272 and then Present
(Finalize_Address
(Desig_Typ
))
1274 -- The finalization master of an anonymous access type may need
1275 -- to be inserted in a specific place in the tree. For instance:
1279 -- <finalization master of "access Comp_Typ">
1281 -- type Rec_Typ is record
1282 -- Comp : access Comp_Typ;
1285 -- <freeze node for Comp_Typ>
1286 -- <freeze node for Rec_Typ>
1288 -- Due to this oddity, the anonymous access type is stored for
1289 -- later processing (see below).
1291 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1294 -- Set_Finalize_Address
1295 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1298 Make_Set_Finalize_Address_Call
1300 Ptr_Typ
=> Ptr_Typ
));
1302 -- Otherwise the designated type is either anonymous access or a
1303 -- Taft-amendment type and has not been frozen. Store the access
1304 -- type for later processing (see Freeze_Type).
1307 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1310 -- A finalization master created for an access designating a type
1311 -- with private components is inserted before a context-dependent
1316 -- At this point both the scope of the context and the insertion
1317 -- mode must be known.
1319 pragma Assert
(Present
(Context_Scope
));
1320 pragma Assert
(Present
(Insertion_Node
));
1322 Push_Scope
(Context_Scope
);
1324 -- Treat use clauses as declarations and insert directly in front
1327 if Nkind
(Insertion_Node
) in
1328 N_Use_Package_Clause | N_Use_Type_Clause
1330 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1332 Insert_Actions
(Insertion_Node
, Actions
);
1337 -- The finalization master belongs to an access result type related
1338 -- to a build-in-place function call used to initialize a library
1339 -- level object. The master must be inserted in front of the access
1340 -- result type declaration denoted by Insertion_Node.
1342 elsif For_Lib_Level
then
1343 pragma Assert
(Present
(Insertion_Node
));
1344 Insert_Actions
(Insertion_Node
, Actions
);
1346 -- Otherwise the finalization master and its initialization become a
1347 -- part of the freeze node.
1350 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1353 Analyze_List
(Actions
);
1355 -- When the type the finalization master is being generated for was
1356 -- created to store a 'Old object, then mark it as such so its
1357 -- finalization can be delayed until after postconditions have been
1360 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1361 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1364 end Build_Finalization_Master
;
1366 ---------------------
1367 -- Build_Finalizer --
1368 ---------------------
1370 procedure Build_Finalizer
1372 Clean_Stmts
: List_Id
;
1373 Mark_Id
: Entity_Id
;
1374 Top_Decls
: List_Id
;
1375 Defer_Abort
: Boolean;
1376 Fin_Id
: out Entity_Id
)
1378 Acts_As_Clean
: constant Boolean :=
1381 (Present
(Clean_Stmts
)
1382 and then Is_Non_Empty_List
(Clean_Stmts
));
1384 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1385 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1386 For_Package
: constant Boolean :=
1387 For_Package_Body
or else For_Package_Spec
;
1388 Loc
: constant Source_Ptr
:= Sloc
(N
);
1390 -- NOTE: Local variable declarations are conservative and do not create
1391 -- structures right from the start. Entities and lists are created once
1392 -- it has been established that N has at least one controlled object.
1394 Components_Built
: Boolean := False;
1395 -- A flag used to avoid double initialization of entities and lists. If
1396 -- the flag is set then the following variables have been initialized:
1402 Counter_Id
: Entity_Id
:= Empty
;
1403 Counter_Val
: Nat
:= 0;
1404 -- Name and value of the state counter
1406 Decls
: List_Id
:= No_List
;
1407 -- Declarative region of N (if available). If N is a package declaration
1408 -- Decls denotes the visible declarations.
1410 Finalizer_Data
: Finalization_Exception_Data
;
1411 -- Data for the exception
1413 Finalizer_Decls
: List_Id
:= No_List
;
1414 -- Local variable declarations. This list holds the label declarations
1415 -- of all jump block alternatives as well as the declaration of the
1416 -- local exception occurrence and the raised flag:
1417 -- E : Exception_Occurrence;
1418 -- Raised : Boolean := False;
1419 -- L<counter value> : label;
1421 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1422 -- Insertion point for the finalizer body. Depending on the context
1423 -- (Nkind of N) and the individual grouping of controlled objects, this
1424 -- node may denote a package declaration or body, package instantiation,
1425 -- block statement or a counter update statement.
1427 Finalizer_Stmts
: List_Id
:= No_List
;
1428 -- The statement list of the finalizer body. It contains the following:
1430 -- Abort_Defer; -- Added if abort is allowed
1431 -- <call to Prev_At_End> -- Added if exists
1432 -- <cleanup statements> -- Added if Acts_As_Clean
1433 -- <jump block> -- Added if Has_Ctrl_Objs
1434 -- <finalization statements> -- Added if Has_Ctrl_Objs
1435 -- <stack release> -- Added if Mark_Id exists
1436 -- Abort_Undefer; -- Added if abort is allowed
1438 Has_Ctrl_Objs
: Boolean := False;
1439 -- A general flag which denotes whether N has at least one controlled
1442 Has_Tagged_Types
: Boolean := False;
1443 -- A general flag which indicates whether N has at least one library-
1444 -- level tagged type declaration.
1446 HSS
: Node_Id
:= Empty
;
1447 -- The sequence of statements of N (if available)
1449 Jump_Alts
: List_Id
:= No_List
;
1450 -- Jump block alternatives. Depending on the value of the state counter,
1451 -- the control flow jumps to a sequence of finalization statements. This
1452 -- list contains the following:
1454 -- when <counter value> =>
1455 -- goto L<counter value>;
1457 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1458 -- Specific point in the finalizer statements where the jump block is
1461 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1462 -- The last controlled construct encountered when processing the top
1463 -- level lists of N. This can be a nested package, an instantiation or
1464 -- an object declaration.
1466 Prev_At_End
: Entity_Id
:= Empty
;
1467 -- The previous at end procedure of the handled statements block of N
1469 Priv_Decls
: List_Id
:= No_List
;
1470 -- The private declarations of N if N is a package declaration
1472 Spec_Id
: Entity_Id
:= Empty
;
1473 Spec_Decls
: List_Id
:= Top_Decls
;
1474 Stmts
: List_Id
:= No_List
;
1476 Tagged_Type_Stmts
: List_Id
:= No_List
;
1477 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1478 -- tagged types found in N.
1480 -----------------------
1481 -- Local subprograms --
1482 -----------------------
1484 procedure Build_Components
;
1485 -- Create all entites and initialize all lists used in the creation of
1488 procedure Create_Finalizer
;
1489 -- Create the spec and body of the finalizer and insert them in the
1490 -- proper place in the tree depending on the context.
1492 function New_Finalizer_Name
1493 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1494 -- Create a fully qualified name of a package spec or body finalizer.
1495 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1497 procedure Process_Declarations
1499 Preprocess
: Boolean := False;
1500 Top_Level
: Boolean := False);
1501 -- Inspect a list of declarations or statements which may contain
1502 -- objects that need finalization. When flag Preprocess is set, the
1503 -- routine will simply count the total number of controlled objects in
1504 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1505 -- when Preprocess is set and if True, the processing is performed for
1506 -- objects in nested package declarations or instances.
1508 procedure Process_Object_Declaration
1510 Has_No_Init
: Boolean := False;
1511 Is_Protected
: Boolean := False);
1512 -- Generate all the machinery associated with the finalization of a
1513 -- single object. Flag Has_No_Init is used to denote certain contexts
1514 -- where Decl does not have initialization call(s). Flag Is_Protected
1515 -- is set when Decl denotes a simple protected object.
1517 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1518 -- Generate all the code necessary to unregister the external tag of a
1521 ----------------------
1522 -- Build_Components --
1523 ----------------------
1525 procedure Build_Components
is
1526 Counter_Decl
: Node_Id
;
1527 Counter_Typ
: Entity_Id
;
1528 Counter_Typ_Decl
: Node_Id
;
1531 pragma Assert
(Present
(Decls
));
1533 -- This routine might be invoked several times when dealing with
1534 -- constructs that have two lists (either two declarative regions
1535 -- or declarations and statements). Avoid double initialization.
1537 if Components_Built
then
1541 Components_Built
:= True;
1543 if Has_Ctrl_Objs
then
1545 -- Create entities for the counter, its type, the local exception
1546 -- and the raised flag.
1548 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1549 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1551 Finalizer_Decls
:= New_List
;
1553 Build_Object_Declarations
1554 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1556 -- Since the total number of controlled objects is always known,
1557 -- build a subtype of Natural with precise bounds. This allows
1558 -- the backend to optimize the case statement. Generate:
1560 -- subtype Tnn is Natural range 0 .. Counter_Val;
1563 Make_Subtype_Declaration
(Loc
,
1564 Defining_Identifier
=> Counter_Typ
,
1565 Subtype_Indication
=>
1566 Make_Subtype_Indication
(Loc
,
1567 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1569 Make_Range_Constraint
(Loc
,
1573 Make_Integer_Literal
(Loc
, Uint_0
),
1575 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1577 -- Generate the declaration of the counter itself:
1579 -- Counter : Integer := 0;
1582 Make_Object_Declaration
(Loc
,
1583 Defining_Identifier
=> Counter_Id
,
1584 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1585 Expression
=> Make_Integer_Literal
(Loc
, 0));
1587 -- Set the type of the counter explicitly to prevent errors when
1588 -- examining object declarations later on.
1590 Set_Etype
(Counter_Id
, Counter_Typ
);
1592 if Debug_Generated_Code
then
1593 Set_Debug_Info_Needed
(Counter_Id
);
1596 -- The counter and its type are inserted before the source
1597 -- declarations of N.
1599 Prepend_To
(Decls
, Counter_Decl
);
1600 Prepend_To
(Decls
, Counter_Typ_Decl
);
1602 -- The counter and its associated type must be manually analyzed
1603 -- since N has already been analyzed.
1605 Analyze
(Counter_Typ_Decl
);
1606 Analyze
(Counter_Decl
);
1608 Jump_Alts
:= New_List
;
1611 -- If the context requires additional cleanup, the finalization
1612 -- machinery is added after the cleanup code.
1614 if Acts_As_Clean
then
1615 Finalizer_Stmts
:= Clean_Stmts
;
1616 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1618 Finalizer_Stmts
:= New_List
;
1621 if Has_Tagged_Types
then
1622 Tagged_Type_Stmts
:= New_List
;
1624 end Build_Components
;
1626 ----------------------
1627 -- Create_Finalizer --
1628 ----------------------
1630 procedure Create_Finalizer
is
1631 Body_Id
: Entity_Id
;
1634 Jump_Block
: Node_Id
;
1636 Label_Id
: Entity_Id
;
1639 -- Step 1: Creation of the finalizer name
1641 -- Packages must use a distinct name for their finalizers since the
1642 -- binder will have to generate calls to them by name. The name is
1643 -- of the following form:
1645 -- xx__yy__finalize_[spec|body]
1648 Fin_Id
:= Make_Defining_Identifier
1649 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1650 Set_Has_Qualified_Name
(Fin_Id
);
1651 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1653 -- The default name is _finalizer
1656 -- Generation of a finalization procedure exclusively for 'Old
1657 -- interally generated constants requires different name since
1658 -- there will need to be multiple finalization routines in the
1659 -- same scope. See Build_Finalizer for details.
1662 Make_Defining_Identifier
(Loc
,
1663 Chars
=> New_External_Name
(Name_uFinalizer
));
1665 -- The visibility semantics of AT_END handlers force a strange
1666 -- separation of spec and body for stack-related finalizers:
1668 -- declare : Enclosing_Scope
1669 -- procedure _finalizer;
1671 -- <controlled objects>
1672 -- procedure _finalizer is
1678 -- Both spec and body are within the same construct and scope, but
1679 -- the body is part of the handled sequence of statements. This
1680 -- placement confuses the elaboration mechanism on targets where
1681 -- AT_END handlers are expanded into "when all others" handlers:
1684 -- when all others =>
1685 -- _finalizer; -- appears to require elab checks
1690 -- Since the compiler guarantees that the body of a _finalizer is
1691 -- always inserted in the same construct where the AT_END handler
1692 -- resides, there is no need for elaboration checks.
1694 Set_Kill_Elaboration_Checks
(Fin_Id
);
1696 -- Inlining the finalizer produces a substantial speedup at -O2.
1697 -- It is inlined by default at -O3. Either way, it is called
1698 -- exactly twice (once on the normal path, and once for
1699 -- exceptions/abort), so this won't bloat the code too much.
1701 Set_Is_Inlined
(Fin_Id
);
1704 if Debug_Generated_Code
then
1705 Set_Debug_Info_Needed
(Fin_Id
);
1708 -- Step 2: Creation of the finalizer specification
1711 -- procedure Fin_Id;
1714 Make_Subprogram_Declaration
(Loc
,
1716 Make_Procedure_Specification
(Loc
,
1717 Defining_Unit_Name
=> Fin_Id
));
1720 Set_Is_Exported
(Fin_Id
);
1721 Set_Interface_Name
(Fin_Id
,
1722 Make_String_Literal
(Loc
,
1723 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1726 -- Step 3: Creation of the finalizer body
1728 -- Has_Ctrl_Objs might be set because of a generic package body having
1729 -- controlled objects. In this case, Jump_Alts may be empty and no
1730 -- case nor goto statements are needed.
1733 and then not Is_Empty_List
(Jump_Alts
)
1735 -- Add L0, the default destination to the jump block
1737 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1738 Set_Entity
(Label_Id
,
1739 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1740 Label
:= Make_Label
(Loc
, Label_Id
);
1745 Prepend_To
(Finalizer_Decls
,
1746 Make_Implicit_Label_Declaration
(Loc
,
1747 Defining_Identifier
=> Entity
(Label_Id
),
1748 Label_Construct
=> Label
));
1754 Append_To
(Jump_Alts
,
1755 Make_Case_Statement_Alternative
(Loc
,
1756 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1757 Statements
=> New_List
(
1758 Make_Goto_Statement
(Loc
,
1759 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1764 Append_To
(Finalizer_Stmts
, Label
);
1766 -- Create the jump block which controls the finalization flow
1767 -- depending on the value of the state counter.
1770 Make_Case_Statement
(Loc
,
1771 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1772 Alternatives
=> Jump_Alts
);
1774 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1775 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1777 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1781 -- Add the library-level tagged type unregistration machinery before
1782 -- the jump block circuitry. This ensures that external tags will be
1783 -- removed even if a finalization exception occurs at some point.
1785 if Has_Tagged_Types
then
1786 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1789 -- Add a call to the previous At_End handler if it exists. The call
1790 -- must always precede the jump block.
1792 if Present
(Prev_At_End
) then
1793 Prepend_To
(Finalizer_Stmts
,
1794 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1796 -- Clear the At_End handler since we have already generated the
1797 -- proper replacement call for it.
1799 Set_At_End_Proc
(HSS
, Empty
);
1802 -- Release the secondary stack
1804 if Present
(Mark_Id
) then
1806 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1809 -- If the context is a build-in-place function, the secondary
1810 -- stack must be released, unless the build-in-place function
1811 -- itself is returning on the secondary stack. Generate:
1813 -- if BIP_Alloc_Form /= Secondary_Stack then
1814 -- SS_Release (Mark_Id);
1817 -- Note that if the function returns on the secondary stack,
1818 -- then the responsibility of reclaiming the space is always
1819 -- left to the caller (recursively if needed).
1821 if Nkind
(N
) = N_Subprogram_Body
then
1823 Spec_Id
: constant Entity_Id
:=
1824 Unique_Defining_Entity
(N
);
1825 BIP_SS
: constant Boolean :=
1826 Is_Build_In_Place_Function
(Spec_Id
)
1827 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1831 Make_If_Statement
(Loc
,
1836 (Build_In_Place_Formal
1837 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1839 Make_Integer_Literal
(Loc
,
1841 (BIP_Allocation_Form
'Pos
1842 (Secondary_Stack
)))),
1844 Then_Statements
=> New_List
(Release
));
1849 Append_To
(Finalizer_Stmts
, Release
);
1853 -- Protect the statements with abort defer/undefer. This is only when
1854 -- aborts are allowed and the cleanup statements require deferral or
1855 -- there are controlled objects to be finalized. Note that the abort
1856 -- defer/undefer pair does not require an extra block because each
1857 -- finalization exception is caught in its corresponding finalization
1858 -- block. As a result, the call to Abort_Defer always takes place.
1860 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1861 Prepend_To
(Finalizer_Stmts
,
1862 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1864 Append_To
(Finalizer_Stmts
,
1865 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1868 -- The local exception does not need to be reraised for library-level
1869 -- finalizers. Note that this action must be carried out after object
1870 -- cleanup, secondary stack release, and abort undeferral. Generate:
1872 -- if Raised and then not Abort then
1873 -- Raise_From_Controlled_Operation (E);
1876 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1877 Append_To
(Finalizer_Stmts
,
1878 Build_Raise_Statement
(Finalizer_Data
));
1882 -- procedure Fin_Id is
1883 -- Abort : constant Boolean := Triggered_By_Abort;
1885 -- Abort : constant Boolean := False; -- no abort
1887 -- E : Exception_Occurrence; -- All added if flag
1888 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1894 -- Abort_Defer; -- Added if abort is allowed
1895 -- <call to Prev_At_End> -- Added if exists
1896 -- <cleanup statements> -- Added if Acts_As_Clean
1897 -- <jump block> -- Added if Has_Ctrl_Objs
1898 -- <finalization statements> -- Added if Has_Ctrl_Objs
1899 -- <stack release> -- Added if Mark_Id exists
1900 -- Abort_Undefer; -- Added if abort is allowed
1901 -- <exception propagation> -- Added if Has_Ctrl_Objs
1904 -- Create the body of the finalizer
1906 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1908 if Debug_Generated_Code
then
1909 Set_Debug_Info_Needed
(Body_Id
);
1913 Set_Has_Qualified_Name
(Body_Id
);
1914 Set_Has_Fully_Qualified_Name
(Body_Id
);
1918 Make_Subprogram_Body
(Loc
,
1920 Make_Procedure_Specification
(Loc
,
1921 Defining_Unit_Name
=> Body_Id
),
1922 Declarations
=> Finalizer_Decls
,
1923 Handled_Statement_Sequence
=>
1924 Make_Handled_Sequence_Of_Statements
(Loc
,
1925 Statements
=> Finalizer_Stmts
));
1927 -- Step 4: Spec and body insertion, analysis
1931 -- If the package spec has private declarations, the finalizer
1932 -- body must be added to the end of the list in order to have
1933 -- visibility of all private controlled objects.
1935 if For_Package_Spec
then
1936 if Present
(Priv_Decls
) then
1937 Append_To
(Priv_Decls
, Fin_Spec
);
1938 Append_To
(Priv_Decls
, Fin_Body
);
1940 Append_To
(Decls
, Fin_Spec
);
1941 Append_To
(Decls
, Fin_Body
);
1944 -- For package bodies, both the finalizer spec and body are
1945 -- inserted at the end of the package declarations.
1948 Append_To
(Decls
, Fin_Spec
);
1949 Append_To
(Decls
, Fin_Body
);
1958 -- Create the spec for the finalizer. The At_End handler must be
1959 -- able to call the body which resides in a nested structure.
1963 -- procedure Fin_Id; -- Spec
1965 -- <objects and possibly statements>
1966 -- procedure Fin_Id is ... -- Body
1969 -- Fin_Id; -- At_End handler
1972 pragma Assert
(Present
(Spec_Decls
));
1974 -- It maybe possible that we are finalizing 'Old objects which
1975 -- exist in the spec declarations. When this is the case the
1976 -- Finalizer_Insert_Node will come before the end of the
1977 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1978 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1979 -- end of Spec_Decls to prevent its body appearing before its
1980 -- corresponding spec.
1982 if Present
(Finalizer_Insert_Nod
)
1983 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
1985 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
1986 Finalizer_Insert_Nod
:= Fin_Spec
;
1988 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
1991 Append_To
(Spec_Decls
, Fin_Spec
);
1995 -- When the finalizer acts solely as a cleanup routine, the body
1996 -- is inserted right after the spec.
1998 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1999 Insert_After
(Fin_Spec
, Fin_Body
);
2001 -- In all other cases the body is inserted after either:
2003 -- 1) The counter update statement of the last controlled object
2004 -- 2) The last top level nested controlled package
2005 -- 3) The last top level controlled instantiation
2008 -- Manually freeze the spec. This is somewhat of a hack because
2009 -- a subprogram is frozen when its body is seen and the freeze
2010 -- node appears right before the body. However, in this case,
2011 -- the spec must be frozen earlier since the At_End handler
2012 -- must be able to call it.
2015 -- procedure Fin_Id; -- Spec
2016 -- [Fin_Id] -- Freeze node
2020 -- Fin_Id; -- At_End handler
2023 Ensure_Freeze_Node
(Fin_Id
);
2024 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2025 Set_Is_Frozen
(Fin_Id
);
2027 -- In the case where the last construct to contain a controlled
2028 -- object is either a nested package, an instantiation or a
2029 -- freeze node, the body must be inserted directly after the
2030 -- construct, except if the insertion point is already placed
2031 -- after the construct, typically in the statement list.
2033 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2034 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2036 (List_Containing
(Last_Top_Level_Ctrl_Construct
) = Spec_Decls
2037 and then Present
(Stmts
)
2038 and then List_Containing
(Finalizer_Insert_Nod
) = Stmts
)
2040 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2043 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2046 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2049 -- Never consider that the finalizer procedure is enabled Ghost, even
2050 -- when the corresponding unit is Ghost, as this would lead to an
2051 -- an external name with a ___ghost_ prefix that the binder cannot
2052 -- generate, as it has no knowledge of the Ghost status of units.
2054 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2055 end Create_Finalizer
;
2057 ------------------------
2058 -- New_Finalizer_Name --
2059 ------------------------
2061 function New_Finalizer_Name
2062 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2064 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2065 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2066 -- has a non-standard scope, process the scope first.
2068 ------------------------
2069 -- New_Finalizer_Name --
2070 ------------------------
2072 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2074 if Scope
(Id
) = Standard_Standard
then
2075 Get_Name_String
(Chars
(Id
));
2078 New_Finalizer_Name
(Scope
(Id
));
2079 Add_Str_To_Name_Buffer
("__");
2080 Get_Name_String_And_Append
(Chars
(Id
));
2082 end New_Finalizer_Name
;
2084 -- Start of processing for New_Finalizer_Name
2087 -- Create the fully qualified name of the enclosing scope
2089 New_Finalizer_Name
(Spec_Id
);
2092 -- __finalize_[spec|body]
2094 Add_Str_To_Name_Buffer
("__finalize_");
2097 Add_Str_To_Name_Buffer
("spec");
2099 Add_Str_To_Name_Buffer
("body");
2103 end New_Finalizer_Name
;
2105 --------------------------
2106 -- Process_Declarations --
2107 --------------------------
2109 procedure Process_Declarations
2111 Preprocess
: Boolean := False;
2112 Top_Level
: Boolean := False)
2117 Obj_Typ
: Entity_Id
;
2118 Pack_Id
: Entity_Id
;
2122 Old_Counter_Val
: Nat
;
2123 -- This variable is used to determine whether a nested package or
2124 -- instance contains at least one controlled object.
2126 procedure Process_Package_Body
(Decl
: Node_Id
);
2127 -- Process an N_Package_Body node
2129 procedure Processing_Actions
2130 (Has_No_Init
: Boolean := False;
2131 Is_Protected
: Boolean := False);
2132 -- Depending on the mode of operation of Process_Declarations, either
2133 -- increment the controlled object counter, set the controlled object
2134 -- flag and store the last top level construct or process the current
2135 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2136 -- the current declaration may not have initialization proc(s). Flag
2137 -- Is_Protected should be set when the current declaration denotes a
2138 -- simple protected object.
2140 --------------------------
2141 -- Process_Package_Body --
2142 --------------------------
2144 procedure Process_Package_Body
(Decl
: Node_Id
) is
2146 -- Do not inspect an ignored Ghost package body because all
2147 -- code found within will not appear in the final tree.
2149 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2152 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
then
2153 Old_Counter_Val
:= Counter_Val
;
2154 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2156 -- The nested package body is the last construct to contain
2157 -- a controlled object.
2161 and then No
(Last_Top_Level_Ctrl_Construct
)
2162 and then Counter_Val
> Old_Counter_Val
2164 Last_Top_Level_Ctrl_Construct
:= Decl
;
2167 end Process_Package_Body
;
2169 ------------------------
2170 -- Processing_Actions --
2171 ------------------------
2173 procedure Processing_Actions
2174 (Has_No_Init
: Boolean := False;
2175 Is_Protected
: Boolean := False)
2178 -- Library-level tagged type
2180 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2182 Has_Tagged_Types
:= True;
2184 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2185 Last_Top_Level_Ctrl_Construct
:= Decl
;
2188 -- Unregister tagged type, unless No_Tagged_Type_Registration
2191 elsif not Restriction_Active
(No_Tagged_Type_Registration
) then
2192 Process_Tagged_Type_Declaration
(Decl
);
2195 -- Controlled object declaration
2199 Counter_Val
:= Counter_Val
+ 1;
2200 Has_Ctrl_Objs
:= True;
2202 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2203 Last_Top_Level_Ctrl_Construct
:= Decl
;
2207 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2210 end Processing_Actions
;
2212 -- Start of processing for Process_Declarations
2215 if Is_Empty_List
(Decls
) then
2219 -- Process all declarations in reverse order
2221 Decl
:= Last_Non_Pragma
(Decls
);
2222 while Present
(Decl
) loop
2223 -- Library-level tagged types
2225 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2226 Typ
:= Defining_Identifier
(Decl
);
2228 -- Ignored Ghost types do not need any cleanup actions because
2229 -- they will not appear in the final tree.
2231 if Is_Ignored_Ghost_Entity
(Typ
) then
2234 elsif Is_Tagged_Type
(Typ
)
2235 and then Is_Library_Level_Entity
(Typ
)
2236 and then Convention
(Typ
) = Convention_Ada
2237 and then Present
(Access_Disp_Table
(Typ
))
2238 and then not Is_Abstract_Type
(Typ
)
2239 and then not No_Run_Time_Mode
2240 and then not Restriction_Active
(No_Tagged_Type_Registration
)
2241 and then RTE_Available
(RE_Register_Tag
)
2246 -- Regular object declarations
2248 elsif Nkind
(Decl
) = N_Object_Declaration
then
2249 Obj_Id
:= Defining_Identifier
(Decl
);
2250 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2251 Expr
:= Expression
(Decl
);
2253 -- Bypass any form of processing for objects which have their
2254 -- finalization disabled. This applies only to objects at the
2257 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2260 -- Finalization of transient objects is treated separately in
2261 -- order to handle sensitive cases. These include:
2263 -- * Conditional expressions
2264 -- * Expressions with actions
2265 -- * Transient scopes
2267 elsif Is_Finalized_Transient
(Obj_Id
) then
2270 -- Finalization of specific objects is also treated separately
2272 elsif Is_Ignored_For_Finalization
(Obj_Id
) then
2275 -- Ignored Ghost objects do not need any cleanup actions
2276 -- because they will not appear in the final tree.
2278 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2281 -- The object is of the form:
2282 -- Obj : [constant] Typ [:= Expr];
2284 -- Do not process the incomplete view of a deferred constant.
2285 -- Note that an object initialized by means of a BIP function
2286 -- call may appear as a deferred constant after expansion
2287 -- activities. These kinds of objects must be finalized.
2289 elsif not Is_Imported
(Obj_Id
)
2290 and then Needs_Finalization
(Obj_Typ
)
2291 and then not (Ekind
(Obj_Id
) = E_Constant
2292 and then not Has_Completion
(Obj_Id
)
2293 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2297 -- The object is of the form:
2298 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2300 -- Obj : Access_Typ :=
2301 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2303 elsif Is_Access_Type
(Obj_Typ
)
2304 and then Needs_Finalization
2305 (Available_View
(Designated_Type
(Obj_Typ
)))
2306 and then Present
(Expr
)
2308 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2310 (Is_Non_BIP_Func_Call
(Expr
)
2311 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2313 Processing_Actions
(Has_No_Init
=> True);
2315 -- Processing for "hook" objects generated for transient
2316 -- objects declared inside an Expression_With_Actions.
2318 elsif Is_Access_Type
(Obj_Typ
)
2319 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2320 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2321 N_Object_Declaration
2323 Processing_Actions
(Has_No_Init
=> True);
2325 -- Process intermediate results of an if expression with one
2326 -- of the alternatives using a controlled function call.
2328 elsif Is_Access_Type
(Obj_Typ
)
2329 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2330 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2331 N_Defining_Identifier
2332 and then Present
(Expr
)
2333 and then Nkind
(Expr
) = N_Null
2335 Processing_Actions
(Has_No_Init
=> True);
2337 -- Simple protected objects which use type System.Tasking.
2338 -- Protected_Objects.Protection to manage their locks should
2339 -- be treated as controlled since they require manual cleanup.
2340 -- The only exception is illustrated in the following example:
2343 -- type Ctrl is new Controlled ...
2344 -- procedure Finalize (Obj : in out Ctrl);
2348 -- package body Pkg is
2349 -- protected Prot is
2350 -- procedure Do_Something (Obj : in out Ctrl);
2353 -- protected body Prot is
2354 -- procedure Do_Something (Obj : in out Ctrl) is ...
2357 -- procedure Finalize (Obj : in out Ctrl) is
2359 -- Prot.Do_Something (Obj);
2363 -- Since for the most part entities in package bodies depend on
2364 -- those in package specs, Prot's lock should be cleaned up
2365 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2366 -- This act however attempts to invoke Do_Something and fails
2367 -- because the lock has disappeared.
2369 elsif Ekind
(Obj_Id
) = E_Variable
2370 and then not In_Library_Level_Package_Body
(Obj_Id
)
2371 and then Has_Simple_Protected_Object
(Obj_Typ
)
2373 Processing_Actions
(Is_Protected
=> True);
2376 -- Specific cases of object renamings
2378 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2379 Obj_Id
:= Defining_Identifier
(Decl
);
2380 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2382 -- Bypass any form of processing for objects which have their
2383 -- finalization disabled. This applies only to objects at the
2386 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2389 -- Ignored Ghost object renamings do not need any cleanup
2390 -- actions because they will not appear in the final tree.
2392 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2395 -- Return object of extended return statements. This case is
2396 -- recognized and marked by the expansion of extended return
2397 -- statements (see Expand_N_Extended_Return_Statement).
2399 elsif Needs_Finalization
(Obj_Typ
)
2400 and then Is_Return_Object
(Obj_Id
)
2401 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2403 Processing_Actions
(Has_No_Init
=> True);
2406 -- Inspect the freeze node of an access-to-controlled type and
2407 -- look for a delayed finalization master. This case arises when
2408 -- the freeze actions are inserted at a later time than the
2409 -- expansion of the context. Since Build_Finalizer is never called
2410 -- on a single construct twice, the master will be ultimately
2411 -- left out and never finalized. This is also needed for freeze
2412 -- actions of designated types themselves, since in some cases the
2413 -- finalization master is associated with a designated type's
2414 -- freeze node rather than that of the access type (see handling
2415 -- for freeze actions in Build_Finalization_Master).
2417 elsif Nkind
(Decl
) = N_Freeze_Entity
2418 and then Present
(Actions
(Decl
))
2420 Typ
:= Entity
(Decl
);
2422 -- Freeze nodes for ignored Ghost types do not need cleanup
2423 -- actions because they will never appear in the final tree.
2425 if Is_Ignored_Ghost_Entity
(Typ
) then
2428 elsif (Is_Access_Object_Type
(Typ
)
2429 and then Needs_Finalization
2430 (Available_View
(Designated_Type
(Typ
))))
2431 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2433 Old_Counter_Val
:= Counter_Val
;
2435 -- Freeze nodes are considered to be identical to packages
2436 -- and blocks in terms of nesting. The difference is that
2437 -- a finalization master created inside the freeze node is
2438 -- at the same nesting level as the node itself.
2440 Process_Declarations
(Actions
(Decl
), Preprocess
);
2442 -- The freeze node contains a finalization master
2446 and then No
(Last_Top_Level_Ctrl_Construct
)
2447 and then Counter_Val
> Old_Counter_Val
2449 Last_Top_Level_Ctrl_Construct
:= Decl
;
2453 -- Nested package declarations, avoid generics
2455 elsif Nkind
(Decl
) = N_Package_Declaration
then
2456 Pack_Id
:= Defining_Entity
(Decl
);
2457 Spec
:= Specification
(Decl
);
2459 -- Do not inspect an ignored Ghost package because all code
2460 -- found within will not appear in the final tree.
2462 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2465 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2466 Old_Counter_Val
:= Counter_Val
;
2467 Process_Declarations
2468 (Private_Declarations
(Spec
), Preprocess
);
2469 Process_Declarations
2470 (Visible_Declarations
(Spec
), Preprocess
);
2472 -- Either the visible or the private declarations contain a
2473 -- controlled object. The nested package declaration is the
2474 -- last such construct.
2478 and then No
(Last_Top_Level_Ctrl_Construct
)
2479 and then Counter_Val
> Old_Counter_Val
2481 Last_Top_Level_Ctrl_Construct
:= Decl
;
2485 -- Nested package bodies, avoid generics
2487 elsif Nkind
(Decl
) = N_Package_Body
then
2488 Process_Package_Body
(Decl
);
2490 elsif Nkind
(Decl
) = N_Package_Body_Stub
2491 and then Present
(Library_Unit
(Decl
))
2493 Process_Package_Body
(Proper_Body
(Unit
(Library_Unit
(Decl
))));
2496 Prev_Non_Pragma
(Decl
);
2498 end Process_Declarations
;
2500 --------------------------------
2501 -- Process_Object_Declaration --
2502 --------------------------------
2504 procedure Process_Object_Declaration
2506 Has_No_Init
: Boolean := False;
2507 Is_Protected
: Boolean := False)
2509 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2510 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2512 Init_Typ
: Entity_Id
;
2513 -- The initialization type of the related object declaration. Note
2514 -- that this is not necessarily the same type as Obj_Typ because of
2515 -- possible type derivations.
2517 Obj_Typ
: Entity_Id
;
2518 -- The type of the related object declaration
2520 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2521 -- Func_Id denotes a build-in-place function. Generate the following
2524 -- if BIPallocfrom > Secondary_Stack'Pos
2525 -- and then BIPfinalizationmaster /= null
2528 -- type Ptr_Typ is access Obj_Typ;
2529 -- for Ptr_Typ'Storage_Pool
2530 -- use Base_Pool (BIPfinalizationmaster);
2532 -- Free (Ptr_Typ (Temp));
2536 -- Obj_Typ is the type of the current object, Temp is the original
2537 -- allocation which Obj_Id renames.
2539 procedure Find_Last_Init
2540 (Last_Init
: out Node_Id
;
2541 Body_Insert
: out Node_Id
);
2542 -- Find the last initialization call related to object declaration
2543 -- Decl. Last_Init denotes the last initialization call which follows
2544 -- Decl. Body_Insert denotes a node where the finalizer body could be
2545 -- potentially inserted after (if blocks are involved).
2547 -----------------------------
2548 -- Build_BIP_Cleanup_Stmts --
2549 -----------------------------
2551 function Build_BIP_Cleanup_Stmts
2552 (Func_Id
: Entity_Id
) return Node_Id
2554 Decls
: constant List_Id
:= New_List
;
2555 Fin_Mas_Id
: constant Entity_Id
:=
2556 Build_In_Place_Formal
2557 (Func_Id
, BIP_Finalization_Master
);
2558 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2559 Temp_Id
: constant Entity_Id
:=
2560 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2564 Free_Stmt
: Node_Id
;
2565 Pool_Id
: Entity_Id
;
2566 Ptr_Typ
: Entity_Id
;
2570 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2572 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2575 Make_Object_Renaming_Declaration
(Loc
,
2576 Defining_Identifier
=> Pool_Id
,
2578 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2580 Make_Explicit_Dereference
(Loc
,
2582 Make_Function_Call
(Loc
,
2584 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2585 Parameter_Associations
=> New_List
(
2586 Make_Explicit_Dereference
(Loc
,
2588 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2590 -- Create an access type which uses the storage pool of the
2591 -- caller's finalization master.
2594 -- type Ptr_Typ is access Func_Typ;
2596 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2599 Make_Full_Type_Declaration
(Loc
,
2600 Defining_Identifier
=> Ptr_Typ
,
2602 Make_Access_To_Object_Definition
(Loc
,
2603 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2605 -- Perform minor decoration in order to set the master and the
2606 -- storage pool attributes.
2608 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2609 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2610 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2612 if Debug_Generated_Code
then
2613 Set_Debug_Info_Needed
(Pool_Id
);
2616 -- Create an explicit free statement. Note that the free uses the
2617 -- caller's pool expressed as a renaming.
2620 Make_Free_Statement
(Loc
,
2622 Unchecked_Convert_To
(Ptr_Typ
,
2623 New_Occurrence_Of
(Temp_Id
, Loc
)));
2625 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2627 -- Create a block to house the dummy type and the instantiation as
2628 -- well as to perform the cleanup the temporary.
2634 -- Free (Ptr_Typ (Temp_Id));
2638 Make_Block_Statement
(Loc
,
2639 Declarations
=> Decls
,
2640 Handled_Statement_Sequence
=>
2641 Make_Handled_Sequence_Of_Statements
(Loc
,
2642 Statements
=> New_List
(Free_Stmt
)));
2645 -- if BIPfinalizationmaster /= null then
2649 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2650 Right_Opnd
=> Make_Null
(Loc
));
2652 -- For unconstrained or tagged results, escalate the condition to
2653 -- include the allocation format. Generate:
2655 -- if BIPallocform > Secondary_Stack'Pos
2656 -- and then BIPfinalizationmaster /= null
2659 if Needs_BIP_Alloc_Form
(Func_Id
) then
2661 Alloc
: constant Entity_Id
:=
2662 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2668 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2670 Make_Integer_Literal
(Loc
,
2672 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2674 Right_Opnd
=> Cond
);
2684 Make_If_Statement
(Loc
,
2686 Then_Statements
=> New_List
(Free_Blk
));
2687 end Build_BIP_Cleanup_Stmts
;
2689 --------------------
2690 -- Find_Last_Init --
2691 --------------------
2693 procedure Find_Last_Init
2694 (Last_Init
: out Node_Id
;
2695 Body_Insert
: out Node_Id
)
2697 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2698 -- Find the last initialization call within the statements of
2701 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2702 -- Determine whether node N denotes one of the initialization
2703 -- procedures of types Init_Typ or Obj_Typ.
2705 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2706 -- Obtain the next statement which follows list member Stmt while
2707 -- ignoring artifacts related to access-before-elaboration checks.
2709 -----------------------------
2710 -- Find_Last_Init_In_Block --
2711 -----------------------------
2713 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2714 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2718 -- Examine the individual statements of the block in reverse to
2719 -- locate the last initialization call.
2721 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2722 Stmt
:= Last
(Statements
(HSS
));
2723 while Present
(Stmt
) loop
2725 -- Peek inside nested blocks in case aborts are allowed
2727 if Nkind
(Stmt
) = N_Block_Statement
then
2728 return Find_Last_Init_In_Block
(Stmt
);
2730 elsif Is_Init_Call
(Stmt
) then
2739 end Find_Last_Init_In_Block
;
2745 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2746 function Is_Init_Proc_Of
2747 (Subp_Id
: Entity_Id
;
2748 Typ
: Entity_Id
) return Boolean;
2749 -- Determine whether subprogram Subp_Id is a valid init proc of
2752 ---------------------
2753 -- Is_Init_Proc_Of --
2754 ---------------------
2756 function Is_Init_Proc_Of
2757 (Subp_Id
: Entity_Id
;
2758 Typ
: Entity_Id
) return Boolean
2760 Deep_Init
: Entity_Id
:= Empty
;
2761 Prim_Init
: Entity_Id
:= Empty
;
2762 Type_Init
: Entity_Id
:= Empty
;
2765 -- Obtain all possible initialization routines of the
2766 -- related type and try to match the subprogram entity
2767 -- against one of them.
2771 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2773 -- Primitive Initialize
2775 if Is_Controlled
(Typ
) then
2776 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2778 if Present
(Prim_Init
) then
2779 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2783 -- Type initialization routine
2785 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2786 Type_Init
:= Base_Init_Proc
(Typ
);
2790 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2792 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2794 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2795 end Is_Init_Proc_Of
;
2799 Call_Id
: Entity_Id
;
2801 -- Start of processing for Is_Init_Call
2804 if Nkind
(N
) = N_Procedure_Call_Statement
2805 and then Nkind
(Name
(N
)) = N_Identifier
2807 Call_Id
:= Entity
(Name
(N
));
2809 -- Consider both the type of the object declaration and its
2810 -- related initialization type.
2813 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2815 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2821 -----------------------------
2822 -- Next_Suitable_Statement --
2823 -----------------------------
2825 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2829 -- Skip call markers and Program_Error raises installed by the
2832 Result
:= Next
(Stmt
);
2833 while Present
(Result
) loop
2834 exit when Nkind
(Result
) not in
2835 N_Call_Marker | N_Raise_Program_Error
;
2841 end Next_Suitable_Statement
;
2849 Deep_Init_Found
: Boolean := False;
2850 -- A flag set when a call to [Deep_]Initialize has been found
2852 -- Start of processing for Find_Last_Init
2856 Body_Insert
:= Empty
;
2858 -- Object renamings and objects associated with controlled
2859 -- function results do not require initialization.
2865 Stmt
:= Next_Suitable_Statement
(Decl
);
2867 -- For an object with suppressed initialization, we check whether
2868 -- there is in fact no initialization expression. If there is not,
2869 -- then this is an object declaration that has been turned into a
2870 -- different object declaration that calls the build-in-place
2871 -- function in a 'Reference attribute, as in "F(...)'Reference".
2872 -- We search for that later object declaration, so that the
2873 -- Inc_Decl will be inserted after the call. Otherwise, if the
2874 -- call raises an exception, we will finalize the (uninitialized)
2875 -- object, which is wrong.
2877 if No_Initialization
(Decl
) then
2878 if No
(Expression
(Last_Init
)) then
2881 exit when No
(Last_Init
);
2882 exit when Nkind
(Last_Init
) = N_Object_Declaration
2883 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2884 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2886 and then Is_Expanded_Build_In_Place_Call
2887 (Prefix
(Expression
(Last_Init
)));
2893 -- If the initialization is in the declaration, we're done, so
2894 -- early return if we have no more statements or they have been
2895 -- rewritten, which means that they were in the source code.
2897 elsif No
(Stmt
) or else Original_Node
(Stmt
) /= Stmt
then
2900 -- In all other cases the initialization calls follow the related
2901 -- object. The general structure of object initialization built by
2902 -- routine Default_Initialize_Object is as follows:
2904 -- [begin -- aborts allowed
2906 -- Type_Init_Proc (Obj);
2907 -- [begin] -- exceptions allowed
2908 -- Deep_Initialize (Obj);
2909 -- [exception -- exceptions allowed
2911 -- Deep_Finalize (Obj, Self => False);
2914 -- [at end -- aborts allowed
2918 -- When aborts are allowed, the initialization calls are housed
2921 elsif Nkind
(Stmt
) = N_Block_Statement
then
2922 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2923 Body_Insert
:= Stmt
;
2925 -- Otherwise the initialization calls follow the related object
2928 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2930 -- Check for an optional call to Deep_Initialize which may
2931 -- appear within a block depending on whether the object has
2932 -- controlled components.
2934 if Present
(Stmt_2
) then
2935 if Nkind
(Stmt_2
) = N_Block_Statement
then
2936 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2938 if Present
(Call
) then
2939 Deep_Init_Found
:= True;
2941 Body_Insert
:= Stmt_2
;
2944 elsif Is_Init_Call
(Stmt_2
) then
2945 Deep_Init_Found
:= True;
2946 Last_Init
:= Stmt_2
;
2947 Body_Insert
:= Last_Init
;
2951 -- If the object lacks a call to Deep_Initialize, then it must
2952 -- have a call to its related type init proc.
2954 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2956 Body_Insert
:= Last_Init
;
2964 Count_Ins
: Node_Id
;
2966 Fin_Stmts
: List_Id
:= No_List
;
2969 Label_Id
: Entity_Id
;
2972 -- Start of processing for Process_Object_Declaration
2975 -- Handle the object type and the reference to the object. Note
2976 -- that objects having simple protected components must retain
2977 -- their original form for the processing below to work.
2979 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2980 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2983 if Is_Access_Type
(Obj_Typ
) then
2984 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2985 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2987 elsif Is_Concurrent_Type
(Obj_Typ
)
2988 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2989 and then not Is_Protected
2991 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2992 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2994 elsif Is_Private_Type
(Obj_Typ
)
2995 and then Present
(Full_View
(Obj_Typ
))
2997 Obj_Typ
:= Full_View
(Obj_Typ
);
2998 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3000 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3001 Obj_Typ
:= Base_Type
(Obj_Typ
);
3002 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3009 Set_Etype
(Obj_Ref
, Obj_Typ
);
3011 -- Handle the initialization type of the object declaration
3013 Init_Typ
:= Obj_Typ
;
3015 if Is_Private_Type
(Init_Typ
)
3016 and then Present
(Full_View
(Init_Typ
))
3018 Init_Typ
:= Full_View
(Init_Typ
);
3020 elsif Is_Untagged_Derivation
(Init_Typ
) then
3021 Init_Typ
:= Root_Type
(Init_Typ
);
3028 -- Set a new value for the state counter and insert the statement
3029 -- after the object declaration. Generate:
3031 -- Counter := <value>;
3034 Make_Assignment_Statement
(Loc
,
3035 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3036 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3038 -- Insert the counter after all initialization has been done. The
3039 -- place of insertion depends on the context.
3041 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3043 -- The object is initialized by a build-in-place function call.
3044 -- The counter insertion point is after the function call.
3046 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3047 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3050 -- The object is initialized by an aggregate. Insert the counter
3051 -- after the last aggregate assignment.
3053 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3054 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3057 -- In all other cases the counter is inserted after the last call
3058 -- to either [Deep_]Initialize or the type-specific init proc.
3061 Find_Last_Init
(Count_Ins
, Body_Ins
);
3064 -- In all other cases the counter is inserted after the last call to
3065 -- either [Deep_]Initialize or the type-specific init proc.
3068 Find_Last_Init
(Count_Ins
, Body_Ins
);
3071 -- If the Initialize function is null or trivial, the call will have
3072 -- been replaced with a null statement, in which case place counter
3073 -- declaration after object declaration itself.
3075 if No
(Count_Ins
) then
3079 Insert_After
(Count_Ins
, Inc_Decl
);
3082 -- If the current declaration is the last in the list, the finalizer
3083 -- body needs to be inserted after the set counter statement for the
3084 -- current object declaration. This is complicated by the fact that
3085 -- the set counter statement may appear in abort deferred block. In
3086 -- that case, the proper insertion place is after the block.
3088 if No
(Finalizer_Insert_Nod
) then
3090 -- Insertion after an abort deferred block
3092 if Present
(Body_Ins
) then
3093 Finalizer_Insert_Nod
:= Body_Ins
;
3095 Finalizer_Insert_Nod
:= Inc_Decl
;
3099 -- Create the associated label with this object, generate:
3101 -- L<counter> : label;
3104 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3106 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3107 Label
:= Make_Label
(Loc
, Label_Id
);
3109 Prepend_To
(Finalizer_Decls
,
3110 Make_Implicit_Label_Declaration
(Loc
,
3111 Defining_Identifier
=> Entity
(Label_Id
),
3112 Label_Construct
=> Label
));
3114 -- Create the associated jump with this object, generate:
3116 -- when <counter> =>
3119 Prepend_To
(Jump_Alts
,
3120 Make_Case_Statement_Alternative
(Loc
,
3121 Discrete_Choices
=> New_List
(
3122 Make_Integer_Literal
(Loc
, Counter_Val
)),
3123 Statements
=> New_List
(
3124 Make_Goto_Statement
(Loc
,
3125 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3127 -- Insert the jump destination, generate:
3131 Append_To
(Finalizer_Stmts
, Label
);
3133 -- Disable warnings on Obj_Id. This works around an issue where GCC
3134 -- is not able to detect that Obj_Id is protected by a counter and
3135 -- emits spurious warnings.
3137 if not Comes_From_Source
(Obj_Id
) then
3138 Set_Warnings_Off
(Obj_Id
);
3141 -- Processing for simple protected objects. Such objects require
3142 -- manual finalization of their lock managers.
3144 if Is_Protected
then
3145 if Is_Simple_Protected_Type
(Obj_Typ
) then
3146 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3148 if Present
(Fin_Call
) then
3149 Fin_Stmts
:= New_List
(Fin_Call
);
3152 elsif Is_Array_Type
(Obj_Typ
) then
3153 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3156 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3161 -- System.Tasking.Protected_Objects.Finalize_Protection
3169 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3170 Fin_Stmts
:= New_List
(
3171 Make_Block_Statement
(Loc
,
3172 Handled_Statement_Sequence
=>
3173 Make_Handled_Sequence_Of_Statements
(Loc
,
3174 Statements
=> Fin_Stmts
,
3176 Exception_Handlers
=> New_List
(
3177 Make_Exception_Handler
(Loc
,
3178 Exception_Choices
=> New_List
(
3179 Make_Others_Choice
(Loc
)),
3181 Statements
=> New_List
(
3182 Make_Null_Statement
(Loc
)))))));
3185 -- Processing for regular controlled objects
3190 -- [Deep_]Finalize (Obj);
3193 -- when Id : others =>
3194 -- if not Raised then
3196 -- Save_Occurrence (E, Id);
3205 -- Guard against a missing [Deep_]Finalize when the object type
3206 -- was not properly frozen.
3208 if No
(Fin_Call
) then
3209 Fin_Call
:= Make_Null_Statement
(Loc
);
3212 -- For CodePeer, the exception handlers normally generated here
3213 -- generate complex flowgraphs which result in capacity problems.
3214 -- Omitting these handlers for CodePeer is justified as follows:
3216 -- If a handler is dead, then omitting it is surely ok
3218 -- If a handler is live, then CodePeer should flag the
3219 -- potentially-exception-raising construct that causes it
3220 -- to be live. That is what we are interested in, not what
3221 -- happens after the exception is raised.
3223 if Exceptions_OK
and not CodePeer_Mode
then
3224 Fin_Stmts
:= New_List
(
3225 Make_Block_Statement
(Loc
,
3226 Handled_Statement_Sequence
=>
3227 Make_Handled_Sequence_Of_Statements
(Loc
,
3228 Statements
=> New_List
(Fin_Call
),
3230 Exception_Handlers
=> New_List
(
3231 Build_Exception_Handler
3232 (Finalizer_Data
, For_Package
)))));
3234 -- When exception handlers are prohibited, the finalization call
3235 -- appears unprotected. Any exception raised during finalization
3236 -- will bypass the circuitry which ensures the cleanup of all
3237 -- remaining objects.
3240 Fin_Stmts
:= New_List
(Fin_Call
);
3243 -- If we are dealing with a return object of a build-in-place
3244 -- function, generate the following cleanup statements:
3246 -- if BIPallocfrom > Secondary_Stack'Pos
3247 -- and then BIPfinalizationmaster /= null
3250 -- type Ptr_Typ is access Obj_Typ;
3251 -- for Ptr_Typ'Storage_Pool use
3252 -- Base_Pool (BIPfinalizationmaster.all).all;
3254 -- Free (Ptr_Typ (Temp));
3258 -- The generated code effectively detaches the temporary from the
3259 -- caller finalization master and deallocates the object.
3261 if Is_Return_Object
(Obj_Id
) then
3263 Func_Id
: constant Entity_Id
:=
3264 Return_Applies_To
(Scope
(Obj_Id
));
3267 if Is_Build_In_Place_Function
(Func_Id
)
3268 and then Needs_BIP_Finalization_Master
(Func_Id
)
3270 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3275 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3276 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3278 -- Temporaries created for the purpose of "exporting" a
3279 -- transient object out of an Expression_With_Actions (EWA)
3280 -- need guards. The following illustrates the usage of such
3283 -- Access_Typ : access [all] Obj_Typ;
3284 -- Temp : Access_Typ := null;
3285 -- <Counter> := ...;
3288 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3289 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3291 -- Temp := Ctrl_Trans'Unchecked_Access;
3294 -- The finalization machinery does not process EWA nodes as
3295 -- this may lead to premature finalization of expressions. Note
3296 -- that Temp is marked as being properly initialized regardless
3297 -- of whether the initialization of Ctrl_Trans succeeded. Since
3298 -- a failed initialization may leave Temp with a value of null,
3299 -- add a guard to handle this case:
3301 -- if Obj /= null then
3302 -- <object finalization statements>
3305 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3306 N_Object_Declaration
3308 Fin_Stmts
:= New_List
(
3309 Make_If_Statement
(Loc
,
3312 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3313 Right_Opnd
=> Make_Null
(Loc
)),
3314 Then_Statements
=> Fin_Stmts
));
3316 -- Return objects use a flag to aid in processing their
3317 -- potential finalization when the enclosing function fails
3318 -- to return properly. Generate:
3321 -- <object finalization statements>
3325 Fin_Stmts
:= New_List
(
3326 Make_If_Statement
(Loc
,
3331 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3333 Then_Statements
=> Fin_Stmts
));
3338 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3340 -- Since the declarations are examined in reverse, the state counter
3341 -- must be decremented in order to keep with the true position of
3344 Counter_Val
:= Counter_Val
- 1;
3345 end Process_Object_Declaration
;
3347 -------------------------------------
3348 -- Process_Tagged_Type_Declaration --
3349 -------------------------------------
3351 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3352 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3353 DT_Ptr
: constant Entity_Id
:=
3354 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3357 -- Ada.Tags.Unregister_Tag (<Typ>P);
3359 Append_To
(Tagged_Type_Stmts
,
3360 Make_Procedure_Call_Statement
(Loc
,
3362 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3363 Parameter_Associations
=> New_List
(
3364 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3365 end Process_Tagged_Type_Declaration
;
3367 -- Start of processing for Build_Finalizer
3372 -- Do not perform this expansion in SPARK mode because it is not
3375 if GNATprove_Mode
then
3379 -- Step 1: Extract all lists which may contain controlled objects or
3380 -- library-level tagged types.
3382 if For_Package_Spec
then
3383 Decls
:= Visible_Declarations
(Specification
(N
));
3384 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3386 -- Retrieve the package spec id
3388 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3390 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3391 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3394 -- Accept statement, block, entry body, package body, protected body,
3395 -- subprogram body or task body.
3398 Decls
:= Declarations
(N
);
3399 HSS
:= Handled_Statement_Sequence
(N
);
3401 if Present
(HSS
) then
3402 if Present
(Statements
(HSS
)) then
3403 Stmts
:= Statements
(HSS
);
3406 if Present
(At_End_Proc
(HSS
)) then
3407 Prev_At_End
:= At_End_Proc
(HSS
);
3411 -- Retrieve the package spec id for package bodies
3413 if For_Package_Body
then
3414 Spec_Id
:= Corresponding_Spec
(N
);
3418 -- We do not need to process nested packages since they are handled by
3419 -- the finalizer of the enclosing scope, including at library level.
3420 -- And we do not build two finalizers for an instance without body that
3421 -- is a library unit (see Analyze_Package_Instantiation).
3424 and then (not Is_Compilation_Unit
(Spec_Id
)
3425 or else (Is_Generic_Instance
(Spec_Id
)
3426 and then Package_Instantiation
(Spec_Id
) = N
))
3431 -- Step 2: Object [pre]processing
3434 -- For package specs and bodies, we are invoked from the Standard
3435 -- scope, so we need to push the specs onto the scope stack first.
3437 Push_Scope
(Spec_Id
);
3439 -- Preprocess the visible declarations now in order to obtain the
3440 -- correct number of controlled object by the time the private
3441 -- declarations are processed.
3443 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3445 -- From all the possible contexts, only package specifications may
3446 -- have private declarations.
3448 if For_Package_Spec
then
3449 Process_Declarations
3450 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3453 -- The current context may lack controlled objects, but require some
3454 -- other form of completion (task termination for instance). In such
3455 -- cases, the finalizer must be created and carry the additional
3458 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3462 -- The preprocessing has determined that the context has controlled
3463 -- objects or library-level tagged types.
3465 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3467 -- Private declarations are processed first in order to preserve
3468 -- possible dependencies between public and private objects.
3470 if For_Package_Spec
then
3471 Process_Declarations
(Priv_Decls
);
3474 Process_Declarations
(Decls
);
3480 -- Preprocess both declarations and statements
3482 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3483 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3485 -- At this point it is known that N has controlled objects. Ensure
3486 -- that N has a declarative list since the finalizer spec will be
3489 if Has_Ctrl_Objs
and then No
(Decls
) then
3490 Set_Declarations
(N
, New_List
);
3491 Decls
:= Declarations
(N
);
3492 Spec_Decls
:= Decls
;
3495 -- The current context may lack controlled objects, but require some
3496 -- other form of completion (task termination for instance). In such
3497 -- cases, the finalizer must be created and carry the additional
3500 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3504 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3505 Process_Declarations
(Stmts
);
3506 Process_Declarations
(Decls
);
3510 -- Step 3: Finalizer creation
3512 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3516 -- Pop the scope that was pushed above for package specs and bodies
3521 end Build_Finalizer
;
3523 --------------------------
3524 -- Build_Finalizer_Call --
3525 --------------------------
3527 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3529 -- Do not perform this expansion in SPARK mode because we do not create
3530 -- finalizers in the first place.
3532 if GNATprove_Mode
then
3536 -- If the construct to be cleaned up is a protected subprogram body, the
3537 -- finalizer call needs to be associated with the block that wraps the
3538 -- unprotected version of the subprogram. The following illustrates this
3541 -- procedure Prot_SubpP is
3542 -- procedure finalizer is
3544 -- Service_Entries (Prot_Obj);
3551 -- Prot_SubpN (Prot_Obj);
3558 Loc
: constant Source_Ptr
:= Sloc
(N
);
3560 Is_Protected_Subp_Body
: constant Boolean :=
3561 Nkind
(N
) = N_Subprogram_Body
3562 and then Is_Protected_Subprogram_Body
(N
);
3563 -- True if N is the protected version of a subprogram that belongs to
3564 -- a protected type.
3566 HSS
: constant Node_Id
:=
3567 (if Is_Protected_Subp_Body
3568 then Handled_Statement_Sequence
3569 (Last
(Statements
(Handled_Statement_Sequence
(N
))))
3570 else Handled_Statement_Sequence
(N
));
3572 -- We attach the At_End_Proc to the HSS if this is an accept
3573 -- statement or extended return statement. Also in the case of
3574 -- a protected subprogram, because if Service_Entries raises an
3575 -- exception, we do not lock the PO, so we also do not want to
3578 Use_HSS
: constant Boolean :=
3579 Nkind
(N
) in N_Accept_Statement | N_Extended_Return_Statement
3580 or else Is_Protected_Subp_Body
;
3582 At_End_Proc_Bearer
: constant Node_Id
:= (if Use_HSS
then HSS
else N
);
3584 pragma Assert
(No
(At_End_Proc
(At_End_Proc_Bearer
)));
3585 Set_At_End_Proc
(At_End_Proc_Bearer
, New_Occurrence_Of
(Fin_Id
, Loc
));
3586 -- Attach reference to finalizer to tree, for LLVM use
3587 Set_Parent
(At_End_Proc
(At_End_Proc_Bearer
), At_End_Proc_Bearer
);
3588 Analyze
(At_End_Proc
(At_End_Proc_Bearer
));
3589 Expand_At_End_Handler
(At_End_Proc_Bearer
, Empty
);
3591 end Build_Finalizer_Call
;
3593 ---------------------
3594 -- Build_Late_Proc --
3595 ---------------------
3597 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3599 for Final_Prim
in Name_Of
'Range loop
3600 if Name_Of
(Final_Prim
) = Nam
then
3603 (Prim
=> Final_Prim
,
3605 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3608 end Build_Late_Proc
;
3610 -------------------------------
3611 -- Build_Object_Declarations --
3612 -------------------------------
3614 procedure Build_Object_Declarations
3615 (Data
: out Finalization_Exception_Data
;
3618 For_Package
: Boolean := False)
3623 -- This variable captures an unused dummy internal entity, see the
3624 -- comment associated with its use.
3627 pragma Assert
(Decls
/= No_List
);
3629 -- Always set the proper location as it may be needed even when
3630 -- exception propagation is forbidden.
3634 if Restriction_Active
(No_Exception_Propagation
) then
3635 Data
.Abort_Id
:= Empty
;
3637 Data
.Raised_Id
:= Empty
;
3641 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3643 -- In certain scenarios, finalization can be triggered by an abort. If
3644 -- the finalization itself fails and raises an exception, the resulting
3645 -- Program_Error must be supressed and replaced by an abort signal. In
3646 -- order to detect this scenario, save the state of entry into the
3647 -- finalization code.
3649 -- This is not needed for library-level finalizers as they are called by
3650 -- the environment task and cannot be aborted.
3652 if not For_Package
then
3653 if Abort_Allowed
then
3654 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3657 -- Abort_Id : constant Boolean := <A_Expr>;
3660 Make_Object_Declaration
(Loc
,
3661 Defining_Identifier
=> Data
.Abort_Id
,
3662 Constant_Present
=> True,
3663 Object_Definition
=>
3664 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3666 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3668 -- Abort is not required
3671 -- Generate a dummy entity to ensure that the internal symbols are
3672 -- in sync when a unit is compiled with and without aborts.
3674 Dummy
:= Make_Temporary
(Loc
, 'A');
3675 Data
.Abort_Id
:= Empty
;
3678 -- Library-level finalizers
3681 Data
.Abort_Id
:= Empty
;
3684 if Exception_Extra_Info
then
3685 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3688 -- E_Id : Exception_Occurrence;
3691 Make_Object_Declaration
(Loc
,
3692 Defining_Identifier
=> Data
.E_Id
,
3693 Object_Definition
=>
3694 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3695 Set_No_Initialization
(Decl
);
3697 Append_To
(Decls
, Decl
);
3704 -- Raised_Id : Boolean := False;
3707 Make_Object_Declaration
(Loc
,
3708 Defining_Identifier
=> Data
.Raised_Id
,
3709 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3710 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3712 if Debug_Generated_Code
then
3713 Set_Debug_Info_Needed
(Data
.Raised_Id
);
3715 end Build_Object_Declarations
;
3717 ---------------------------
3718 -- Build_Raise_Statement --
3719 ---------------------------
3721 function Build_Raise_Statement
3722 (Data
: Finalization_Exception_Data
) return Node_Id
3728 -- Standard run-time use the specialized routine
3729 -- Raise_From_Controlled_Operation.
3731 if Exception_Extra_Info
3732 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3735 Make_Procedure_Call_Statement
(Data
.Loc
,
3738 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3739 Parameter_Associations
=>
3740 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3742 -- Restricted run-time: exception messages are not supported and hence
3743 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3748 Make_Raise_Program_Error
(Data
.Loc
,
3749 Reason
=> PE_Finalize_Raised_Exception
);
3754 -- Raised_Id and then not Abort_Id
3758 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3760 if Present
(Data
.Abort_Id
) then
3761 Expr
:= Make_And_Then
(Data
.Loc
,
3764 Make_Op_Not
(Data
.Loc
,
3765 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3770 -- if Raised_Id and then not Abort_Id then
3771 -- Raise_From_Controlled_Operation (E_Id);
3773 -- raise Program_Error; -- restricted runtime
3777 Make_If_Statement
(Data
.Loc
,
3779 Then_Statements
=> New_List
(Stmt
));
3780 end Build_Raise_Statement
;
3782 -----------------------------
3783 -- Build_Record_Deep_Procs --
3784 -----------------------------
3786 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3790 (Prim
=> Initialize_Case
,
3792 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3794 if not Is_Inherently_Limited_Type
(Typ
) then
3797 (Prim
=> Adjust_Case
,
3799 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3802 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3803 -- suppressed since these routine will not be used.
3805 if not Restriction_Active
(No_Finalization
) then
3808 (Prim
=> Finalize_Case
,
3810 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3812 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3814 if not CodePeer_Mode
then
3817 (Prim
=> Address_Case
,
3819 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3822 end Build_Record_Deep_Procs
;
3828 function Cleanup_Array
3831 Typ
: Entity_Id
) return List_Id
3833 Loc
: constant Source_Ptr
:= Sloc
(N
);
3834 Index_List
: constant List_Id
:= New_List
;
3836 function Free_Component
return List_Id
;
3837 -- Generate the code to finalize the task or protected subcomponents
3838 -- of a single component of the array.
3840 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3841 -- Generate a loop over one dimension of the array
3843 --------------------
3844 -- Free_Component --
3845 --------------------
3847 function Free_Component
return List_Id
is
3848 Stmts
: List_Id
:= New_List
;
3850 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3853 -- Component type is known to contain tasks or protected objects
3856 Make_Indexed_Component
(Loc
,
3857 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3858 Expressions
=> Index_List
);
3860 Set_Etype
(Tsk
, C_Typ
);
3862 if Is_Task_Type
(C_Typ
) then
3863 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3865 elsif Is_Simple_Protected_Type
(C_Typ
) then
3866 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3868 elsif Is_Record_Type
(C_Typ
) then
3869 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3871 elsif Is_Array_Type
(C_Typ
) then
3872 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3878 ------------------------
3879 -- Free_One_Dimension --
3880 ------------------------
3882 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3886 if Dim
> Number_Dimensions
(Typ
) then
3887 return Free_Component
;
3889 -- Here we generate the required loop
3892 Index
:= Make_Temporary
(Loc
, 'J');
3893 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3896 Make_Implicit_Loop_Statement
(N
,
3897 Identifier
=> Empty
,
3899 Make_Iteration_Scheme
(Loc
,
3900 Loop_Parameter_Specification
=>
3901 Make_Loop_Parameter_Specification
(Loc
,
3902 Defining_Identifier
=> Index
,
3903 Discrete_Subtype_Definition
=>
3904 Make_Attribute_Reference
(Loc
,
3905 Prefix
=> Duplicate_Subexpr
(Obj
),
3906 Attribute_Name
=> Name_Range
,
3907 Expressions
=> New_List
(
3908 Make_Integer_Literal
(Loc
, Dim
))))),
3909 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3911 end Free_One_Dimension
;
3913 -- Start of processing for Cleanup_Array
3916 return Free_One_Dimension
(1);
3919 --------------------
3920 -- Cleanup_Record --
3921 --------------------
3923 function Cleanup_Record
3926 Typ
: Entity_Id
) return List_Id
3928 Loc
: constant Source_Ptr
:= Sloc
(N
);
3929 Stmts
: constant List_Id
:= New_List
;
3930 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3936 if Has_Discriminants
(U_Typ
)
3937 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3938 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3941 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3943 -- For now, do not attempt to free a component that may appear in a
3944 -- variant, and instead issue a warning. Doing this "properly" would
3945 -- require building a case statement and would be quite a mess. Note
3946 -- that the RM only requires that free "work" for the case of a task
3947 -- access value, so already we go way beyond this in that we deal
3948 -- with the array case and non-discriminated record cases.
3951 ("task/protected object in variant record will not be freed??", N
);
3952 return New_List
(Make_Null_Statement
(Loc
));
3955 Comp
:= First_Component
(U_Typ
);
3956 while Present
(Comp
) loop
3957 if Chars
(Comp
) /= Name_uParent
3958 and then (Has_Task
(Etype
(Comp
))
3959 or else Has_Simple_Protected_Object
(Etype
(Comp
)))
3962 Make_Selected_Component
(Loc
,
3963 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3964 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3965 Set_Etype
(Tsk
, Etype
(Comp
));
3967 if Is_Task_Type
(Etype
(Comp
)) then
3968 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3970 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3971 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3973 elsif Is_Record_Type
(Etype
(Comp
)) then
3975 -- Recurse, by generating the prefix of the argument to the
3976 -- eventual cleanup call.
3978 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3980 elsif Is_Array_Type
(Etype
(Comp
)) then
3981 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3985 Next_Component
(Comp
);
3991 ------------------------------
3992 -- Cleanup_Protected_Object --
3993 ------------------------------
3995 function Cleanup_Protected_Object
3997 Ref
: Node_Id
) return Node_Id
3999 Loc
: constant Source_Ptr
:= Sloc
(N
);
4002 -- For restricted run-time libraries (Ravenscar), tasks are
4003 -- non-terminating, and protected objects can only appear at library
4004 -- level, so we do not want finalization of protected objects.
4006 if Restricted_Profile
then
4011 Make_Procedure_Call_Statement
(Loc
,
4013 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4014 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4016 end Cleanup_Protected_Object
;
4022 function Cleanup_Task
4024 Ref
: Node_Id
) return Node_Id
4026 Loc
: constant Source_Ptr
:= Sloc
(N
);
4029 -- For restricted run-time libraries (Ravenscar), tasks are
4030 -- non-terminating and they can only appear at library level,
4031 -- so we do not want finalization of task objects.
4033 if Restricted_Profile
then
4038 Make_Procedure_Call_Statement
(Loc
,
4040 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4041 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4045 --------------------------------------
4046 -- Check_Unnesting_Elaboration_Code --
4047 --------------------------------------
4049 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4050 Loc
: constant Source_Ptr
:= Sloc
(N
);
4051 Block_Elab_Proc
: Entity_Id
:= Empty
;
4053 procedure Set_Block_Elab_Proc
;
4054 -- Create a defining identifier for a procedure that will replace
4055 -- a block with nested subprograms (unless it has already been created,
4056 -- in which case this is a no-op).
4058 procedure Set_Block_Elab_Proc
is
4060 if No
(Block_Elab_Proc
) then
4061 Block_Elab_Proc
:= Make_Temporary
(Loc
, 'I');
4063 end Set_Block_Elab_Proc
;
4065 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4066 -- Find entities in the elaboration code of a library package body that
4067 -- contain or represent a subprogram body. A body can appear within a
4068 -- block or a loop or can appear by itself if generated for an object
4069 -- declaration that involves controlled actions. The first such entity
4070 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4071 -- that will be used to reset the scopes of all entities that become
4072 -- local to the new elaboration procedure. This is needed for subsequent
4073 -- unnesting actions, which depend on proper setting of the Scope links
4074 -- to determine the nesting level of each subprogram.
4076 -----------------------
4077 -- Find_Local_Scope --
4078 -----------------------
4080 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4087 while Present
(Stat
) loop
4088 case Nkind
(Stat
) is
4089 when N_Block_Statement
=>
4090 if Present
(Identifier
(Stat
)) then
4091 Id
:= Entity
(Identifier
(Stat
));
4093 -- The Scope of this block needs to be reset to the new
4094 -- procedure if the block contains nested subprograms.
4096 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4097 Set_Block_Elab_Proc
;
4098 Set_Scope
(Id
, Block_Elab_Proc
);
4102 when N_Loop_Statement
=>
4103 Id
:= Entity
(Identifier
(Stat
));
4105 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4106 if Scope
(Id
) = Current_Scope
then
4107 Set_Block_Elab_Proc
;
4108 Set_Scope
(Id
, Block_Elab_Proc
);
4112 -- We traverse the loop's statements as well, which may
4113 -- include other block (etc.) statements that need to have
4114 -- their Scope set to Block_Elab_Proc. (Is this really the
4115 -- case, or do such nested blocks refer to the loop scope
4116 -- rather than the loop's enclosing scope???.)
4118 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4120 when N_If_Statement
=>
4121 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4122 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4124 Node
:= First
(Elsif_Parts
(Stat
));
4125 while Present
(Node
) loop
4126 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4130 when N_Case_Statement
=>
4131 Node
:= First
(Alternatives
(Stat
));
4132 while Present
(Node
) loop
4133 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4137 -- Reset the Scope of a subprogram occurring at the top level
4139 when N_Subprogram_Body
=>
4140 Id
:= Defining_Entity
(Stat
);
4142 Set_Block_Elab_Proc
;
4143 Set_Scope
(Id
, Block_Elab_Proc
);
4151 end Reset_Scopes_To_Block_Elab_Proc
;
4155 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4156 Elab_Body
: Node_Id
;
4157 Elab_Call
: Node_Id
;
4159 -- Start of processing for Check_Unnesting_Elaboration_Code
4162 if Present
(H_Seq
) then
4163 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4165 -- There may be subprograms declared in the exception handlers
4166 -- of the current body.
4168 if Present
(Exception_Handlers
(H_Seq
)) then
4170 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4172 while Present
(Handler
) loop
4173 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4180 if Present
(Block_Elab_Proc
) then
4182 Make_Subprogram_Body
(Loc
,
4184 Make_Procedure_Specification
(Loc
,
4185 Defining_Unit_Name
=> Block_Elab_Proc
),
4186 Declarations
=> New_List
,
4187 Handled_Statement_Sequence
=>
4188 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4191 Make_Procedure_Call_Statement
(Loc
,
4192 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4194 Append_To
(Declarations
(N
), Elab_Body
);
4195 Analyze
(Elab_Body
);
4196 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4198 Set_Handled_Statement_Sequence
(N
,
4199 Make_Handled_Sequence_Of_Statements
(Loc
,
4200 Statements
=> New_List
(Elab_Call
)));
4202 Analyze
(Elab_Call
);
4204 -- Could we reset the scopes of entities associated with the new
4205 -- procedure here via a loop over entities rather than doing it in
4206 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4209 end Check_Unnesting_Elaboration_Code
;
4211 ---------------------------------------
4212 -- Check_Unnesting_In_Decls_Or_Stmts --
4213 ---------------------------------------
4215 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4216 Decl_Or_Stmt
: Node_Id
;
4219 if Unnest_Subprogram_Mode
4220 and then Present
(Decls_Or_Stmts
)
4222 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4223 while Present
(Decl_Or_Stmt
) loop
4224 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4225 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4227 Unnest_Block
(Decl_Or_Stmt
);
4229 -- If-statements may contain subprogram bodies at the outer level
4230 -- of their statement lists, and the subprograms may make up-level
4231 -- references (such as to objects declared in the same statement
4232 -- list). Unlike block and loop cases, however, we don't have an
4233 -- entity on which to test the Contains_Subprogram flag, so
4234 -- Unnest_If_Statement must traverse the statement lists to
4235 -- determine whether there are nested subprograms present.
4237 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4238 Unnest_If_Statement
(Decl_Or_Stmt
);
4240 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4242 Id
: constant Entity_Id
:=
4243 Entity
(Identifier
(Decl_Or_Stmt
));
4246 -- When a top-level loop within declarations of a library
4247 -- package spec or body contains nested subprograms, we wrap
4248 -- it in a procedure to handle possible up-level references
4249 -- to entities associated with the loop (such as loop
4252 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4253 Unnest_Loop
(Decl_Or_Stmt
);
4257 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4258 and then not Modify_Tree_For_C
4260 Check_Unnesting_In_Decls_Or_Stmts
4261 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4262 Check_Unnesting_In_Decls_Or_Stmts
4263 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4265 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4266 and then not Modify_Tree_For_C
4268 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4269 if Present
(Statements
4270 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4272 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4273 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4274 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4278 Next
(Decl_Or_Stmt
);
4281 end Check_Unnesting_In_Decls_Or_Stmts
;
4283 ---------------------------------
4284 -- Check_Unnesting_In_Handlers --
4285 ---------------------------------
4287 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4288 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4291 if Present
(Stmt_Seq
)
4292 and then Present
(Exception_Handlers
(Stmt_Seq
))
4295 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4297 while Present
(Handler
) loop
4298 if Present
(Statements
(Handler
)) then
4299 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4306 end Check_Unnesting_In_Handlers
;
4308 ------------------------------
4309 -- Check_Visibly_Controlled --
4310 ------------------------------
4312 procedure Check_Visibly_Controlled
4313 (Prim
: Final_Primitives
;
4315 E
: in out Entity_Id
;
4316 Cref
: in out Node_Id
)
4318 Parent_Type
: Entity_Id
;
4322 if Is_Derived_Type
(Typ
)
4323 and then Comes_From_Source
(E
)
4324 and then No
(Overridden_Operation
(E
))
4326 -- We know that the explicit operation on the type does not override
4327 -- the inherited operation of the parent, and that the derivation
4328 -- is from a private type that is not visibly controlled.
4330 Parent_Type
:= Etype
(Typ
);
4331 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4333 if Present
(Op
) then
4336 -- Wrap the object to be initialized into the proper
4337 -- unchecked conversion, to be compatible with the operation
4340 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4341 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4343 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4347 end Check_Visibly_Controlled
;
4349 --------------------------
4350 -- Contains_Subprogram --
4351 --------------------------
4353 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4357 E
:= First_Entity
(Blk
);
4359 -- The compiler may generate loops with a declare block containing
4360 -- nested procedures used for finalization. Recursively search for
4361 -- subprograms in such constructs.
4363 if Ekind
(Blk
) = E_Loop
4364 and then Parent_Kind
(Blk
) = N_Loop_Statement
4367 Stmt
: Node_Id
:= First
(Statements
(Parent
(Blk
)));
4369 while Present
(Stmt
) loop
4370 if Nkind
(Stmt
) = N_Block_Statement
then
4372 Id
: constant Entity_Id
:=
4373 Entity
(Identifier
(Stmt
));
4375 if Contains_Subprogram
(Id
) then
4385 while Present
(E
) loop
4386 if Is_Subprogram
(E
) then
4389 elsif Ekind
(E
) in E_Block | E_Loop
4390 and then Contains_Subprogram
(E
)
4399 end Contains_Subprogram
;
4405 function Convert_View
(Proc
: Entity_Id
; Arg
: Node_Id
) return Node_Id
is
4406 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Proc
));
4411 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
4412 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4414 Atyp
:= Etype
(Arg
);
4417 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4418 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4420 elsif Present
(Atyp
)
4421 and then Atyp
/= Ftyp
4422 and then (Is_Private_Type
(Ftyp
)
4423 or else Is_Private_Type
(Atyp
)
4424 or else Is_Private_Type
(Base_Type
(Atyp
)))
4425 and then Implementation_Base_Type
(Atyp
) =
4426 Implementation_Base_Type
(Ftyp
)
4428 return Unchecked_Convert_To
(Ftyp
, Arg
);
4430 -- If the argument is already a conversion, as generated by
4431 -- Make_Init_Call, set the target type to the type of the formal
4432 -- directly, to avoid spurious typing problems.
4434 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
4435 and then not Is_Class_Wide_Type
(Atyp
)
4437 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4438 Set_Etype
(Arg
, Ftyp
);
4441 -- Otherwise, introduce a conversion when the designated object
4442 -- has a type derived from the formal of the controlled routine.
4444 elsif Is_Private_Type
(Ftyp
)
4445 and then Present
(Atyp
)
4446 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4448 return Unchecked_Convert_To
(Ftyp
, Arg
);
4455 -------------------------------
4456 -- Establish_Transient_Scope --
4457 -------------------------------
4459 -- This procedure is called each time a transient block has to be inserted
4460 -- that is to say for each call to a function with unconstrained or tagged
4461 -- result. It creates a new scope on the scope stack in order to enclose
4462 -- all transient variables generated.
4464 procedure Establish_Transient_Scope
4466 Manage_Sec_Stack
: Boolean)
4468 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4469 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4471 function Find_Enclosing_Transient_Scope
return Int
;
4472 -- Examine the scope stack looking for the nearest enclosing transient
4473 -- scope within the innermost enclosing package or subprogram. Return
4474 -- its index in the table or else -1 if no such scope exists.
4476 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
4477 -- Locate a suitable context for arbitrary node N which may need to be
4478 -- serviced by a transient scope. Return Empty if no suitable context
4481 procedure Delegate_Sec_Stack_Management
;
4482 -- Move the management of the secondary stack to the nearest enclosing
4485 procedure Create_Transient_Scope
(Context
: Node_Id
);
4486 -- Place a new scope on the scope stack in order to service construct
4487 -- Context. Context is the node found by Find_Transient_Context. The
4488 -- new scope may also manage the secondary stack.
4490 ----------------------------
4491 -- Create_Transient_Scope --
4492 ----------------------------
4494 procedure Create_Transient_Scope
(Context
: Node_Id
) is
4495 Loc
: constant Source_Ptr
:= Sloc
(N
);
4497 Iter_Loop
: Entity_Id
;
4498 Trans_Scop
: constant Entity_Id
:=
4499 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4502 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4504 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4507 Push_Scope
(Trans_Scop
);
4508 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
4509 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= True;
4511 -- The transient scope must also manage the secondary stack
4513 if Manage_Sec_Stack
then
4514 Set_Uses_Sec_Stack
(Trans_Scop
);
4515 Check_Restriction
(No_Secondary_Stack
, N
);
4517 -- The expansion of iterator loops generates references to objects
4518 -- in order to extract elements from a container:
4520 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4521 -- Obj : <object type> renames Ref.all.Element.all;
4523 -- These references are controlled and returned on the secondary
4524 -- stack. A new reference is created at each iteration of the loop
4525 -- and as a result it must be finalized and the space occupied by
4526 -- it on the secondary stack reclaimed at the end of the current
4529 -- When the context that requires a transient scope is a call to
4530 -- routine Reference, the node to be wrapped is the source object:
4532 -- for Obj of Container loop
4534 -- Routine Wrap_Transient_Declaration however does not generate
4535 -- a physical block as wrapping a declaration will kill it too
4536 -- early. To handle this peculiar case, mark the related iterator
4537 -- loop as requiring the secondary stack. This signals the
4538 -- finalization machinery to manage the secondary stack (see
4539 -- routine Process_Statements_For_Controlled_Objects).
4541 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4543 if Present
(Iter_Loop
) then
4544 Set_Uses_Sec_Stack
(Iter_Loop
);
4548 if Debug_Flag_W
then
4549 Write_Str
(" <Transient>");
4552 end Create_Transient_Scope
;
4554 -----------------------------------
4555 -- Delegate_Sec_Stack_Management --
4556 -----------------------------------
4558 procedure Delegate_Sec_Stack_Management
is
4560 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4562 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4564 -- Prevent the search from going too far or within the scope
4565 -- space of another unit.
4567 if Scope
.Entity
= Standard_Standard
then
4570 -- No transient scope should be encountered during the
4571 -- traversal because Establish_Transient_Scope should have
4572 -- already handled this case.
4574 elsif Scope
.Is_Transient
then
4575 raise Program_Error
;
4577 -- The construct that requires secondary stack management is
4578 -- always enclosed by a package or subprogram scope.
4580 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
4581 Set_Uses_Sec_Stack
(Scope
.Entity
);
4582 Check_Restriction
(No_Secondary_Stack
, N
);
4589 -- At this point no suitable scope was found. This should never occur
4590 -- because a construct is always enclosed by a compilation unit which
4593 pragma Assert
(False);
4594 end Delegate_Sec_Stack_Management
;
4596 ------------------------------------
4597 -- Find_Enclosing_Transient_Scope --
4598 ------------------------------------
4600 function Find_Enclosing_Transient_Scope
return Int
is
4602 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4604 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4606 -- Prevent the search from going too far or within the scope
4607 -- space of another unit.
4609 if Scope
.Entity
= Standard_Standard
4610 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
4614 elsif Scope
.Is_Transient
then
4621 end Find_Enclosing_Transient_Scope
;
4623 ----------------------------
4624 -- Find_Transient_Context --
4625 ----------------------------
4627 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
4628 Curr
: Node_Id
:= N
;
4629 Prev
: Node_Id
:= Empty
;
4632 while Present
(Curr
) loop
4633 case Nkind
(Curr
) is
4637 -- Declarations act as a boundary for a transient scope even if
4638 -- they are not wrapped, see Wrap_Transient_Declaration.
4640 when N_Object_Declaration
4641 | N_Object_Renaming_Declaration
4642 | N_Subtype_Declaration
4648 -- Statements and statement-like constructs act as a boundary
4649 -- for a transient scope.
4651 when N_Accept_Alternative
4652 | N_Attribute_Definition_Clause
4654 | N_Case_Statement_Alternative
4656 | N_Delay_Alternative
4657 | N_Delay_Until_Statement
4658 | N_Delay_Relative_Statement
4659 | N_Discriminant_Association
4661 | N_Entry_Body_Formal_Part
4664 | N_Iteration_Scheme
4665 | N_Terminate_Alternative
4667 pragma Assert
(Present
(Prev
));
4670 when N_Assignment_Statement
=>
4673 when N_Entry_Call_Statement
4674 | N_Procedure_Call_Statement
4676 -- When an entry or procedure call acts as the alternative
4677 -- of a conditional or timed entry call, the proper context
4678 -- is that of the alternative.
4680 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
4681 and then Nkind
(Parent
(Parent
(Curr
))) in
4682 N_Conditional_Entry_Call | N_Timed_Entry_Call
4684 return Parent
(Parent
(Curr
));
4686 -- General case for entry or procedure calls
4694 -- Pragma Check is not a valid transient context in
4695 -- GNATprove mode because the pragma must remain unchanged.
4698 and then Get_Pragma_Id
(Curr
) = Pragma_Check
4702 -- General case for pragmas
4708 when N_Raise_Statement
=>
4711 when N_Simple_Return_Statement
=>
4713 Fun_Id
: constant Entity_Id
:=
4714 Return_Applies_To
(Return_Statement_Entity
(Curr
));
4717 -- A transient context that must manage the secondary
4718 -- stack cannot be a return statement of a function that
4719 -- itself requires secondary stack management, because
4720 -- the function's result would be reclaimed too early.
4721 -- And returns of thunks never require transient scopes.
4723 if (Manage_Sec_Stack
4724 and then Needs_Secondary_Stack
(Etype
(Fun_Id
)))
4725 or else Is_Thunk
(Fun_Id
)
4729 -- General case for return statements
4738 when N_Attribute_Reference
=>
4739 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
4743 -- An Ada 2012 iterator specification is not a valid context
4744 -- because Analyze_Iterator_Specification already employs
4745 -- special processing for it.
4747 when N_Iterator_Specification
=>
4750 when N_Loop_Parameter_Specification
=>
4752 -- An iteration scheme is not a valid context because
4753 -- routine Analyze_Iteration_Scheme already employs
4754 -- special processing.
4756 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
4759 return Parent
(Curr
);
4764 -- The following nodes represent "dummy contexts" which do not
4765 -- need to be wrapped.
4767 when N_Component_Declaration
4768 | N_Discriminant_Specification
4769 | N_Parameter_Specification
4773 -- If the traversal leaves a scope without having been able to
4774 -- find a construct to wrap, something is going wrong, but this
4775 -- can happen in error situations that are not detected yet
4776 -- (such as a dynamic string in a pragma Export).
4778 when N_Block_Statement
4781 | N_Package_Declaration
4795 Curr
:= Parent
(Curr
);
4799 end Find_Transient_Context
;
4801 ------------------------------
4802 -- Is_Package_Or_Subprogram --
4803 ------------------------------
4805 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4807 return Ekind
(Id
) in E_Entry
4812 | E_Subprogram_Body
;
4813 end Is_Package_Or_Subprogram
;
4817 Trans_Idx
: constant Int
:= Find_Enclosing_Transient_Scope
;
4820 -- Start of processing for Establish_Transient_Scope
4823 -- Do not create a new transient scope if there is already an enclosing
4824 -- transient scope within the innermost enclosing package or subprogram.
4826 if Trans_Idx
>= 0 then
4828 -- If the transient scope was requested for purposes of managing the
4829 -- secondary stack, then the existing scope must perform this task,
4830 -- unless the node to be wrapped is a return statement of a function
4831 -- that requires secondary stack management, because the function's
4832 -- result would be reclaimed too early (see Find_Transient_Context).
4834 if Manage_Sec_Stack
then
4836 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Trans_Idx
);
4839 if Nkind
(SE
.Node_To_Be_Wrapped
) /= N_Simple_Return_Statement
4841 Needs_Secondary_Stack
4844 (Return_Statement_Entity
(SE
.Node_To_Be_Wrapped
))))
4846 Set_Uses_Sec_Stack
(SE
.Entity
);
4854 -- Find the construct that must be serviced by a new transient scope, if
4857 Context
:= Find_Transient_Context
(N
);
4859 if Present
(Context
) then
4860 if Nkind
(Context
) = N_Assignment_Statement
then
4862 -- An assignment statement with suppressed controlled semantics
4863 -- does not need a transient scope because finalization is not
4864 -- desirable at this point. Note that No_Ctrl_Actions is also
4865 -- set for non-controlled assignments to suppress dispatching
4868 if No_Ctrl_Actions
(Context
)
4869 and then Needs_Finalization
(Etype
(Name
(Context
)))
4871 -- When a controlled component is initialized by a function
4872 -- call, the result on the secondary stack is always assigned
4873 -- to the component. Signal the nearest suitable scope that it
4874 -- is safe to manage the secondary stack.
4876 if Manage_Sec_Stack
and then Within_Init_Proc
then
4877 Delegate_Sec_Stack_Management
;
4880 -- Otherwise the assignment is a normal transient context and thus
4881 -- requires a transient scope.
4884 Create_Transient_Scope
(Context
);
4890 Create_Transient_Scope
(Context
);
4893 end Establish_Transient_Scope
;
4895 ----------------------------
4896 -- Expand_Cleanup_Actions --
4897 ----------------------------
4899 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4901 (Nkind
(N
) in N_Block_Statement
4905 | N_Extended_Return_Statement
);
4907 Scop
: constant Entity_Id
:= Current_Scope
;
4909 Is_Asynchronous_Call
: constant Boolean :=
4910 Nkind
(N
) = N_Block_Statement
4911 and then Is_Asynchronous_Call_Block
(N
);
4912 Is_Master
: constant Boolean :=
4913 Nkind
(N
) /= N_Extended_Return_Statement
4914 and then Nkind
(N
) /= N_Entry_Body
4915 and then Is_Task_Master
(N
);
4916 Is_Protected_Subp_Body
: constant Boolean :=
4917 Nkind
(N
) = N_Subprogram_Body
4918 and then Is_Protected_Subprogram_Body
(N
);
4919 Is_Task_Allocation
: constant Boolean :=
4920 Nkind
(N
) = N_Block_Statement
4921 and then Is_Task_Allocation_Block
(N
);
4922 Is_Task_Body
: constant Boolean :=
4923 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4925 -- We mark the secondary stack if it is used in this construct, and
4926 -- we're not returning a function result on the secondary stack, except
4927 -- that a build-in-place function that might or might not return on the
4928 -- secondary stack always needs a mark. A run-time test is required in
4929 -- the case where the build-in-place function has a BIP_Alloc extra
4930 -- parameter (see Create_Finalizer).
4932 Needs_Sec_Stack_Mark
: constant Boolean :=
4933 (Uses_Sec_Stack
(Scop
)
4935 not Sec_Stack_Needed_For_Return
(Scop
))
4937 (Is_Build_In_Place_Function
(Scop
)
4938 and then Needs_BIP_Alloc_Form
(Scop
));
4940 Needs_Custom_Cleanup
: constant Boolean :=
4941 Nkind
(N
) = N_Block_Statement
4942 and then Present
(Cleanup_Actions
(N
));
4944 Actions_Required
: constant Boolean :=
4945 Requires_Cleanup_Actions
(N
, True)
4946 or else Is_Asynchronous_Call
4948 or else Is_Protected_Subp_Body
4949 or else Is_Task_Allocation
4950 or else Is_Task_Body
4951 or else Needs_Sec_Stack_Mark
4952 or else Needs_Custom_Cleanup
;
4957 -- Start of processing for Expand_Cleanup_Actions
4960 -- The current construct does not need any form of servicing
4962 if not Actions_Required
then
4966 -- If an extended return statement contains something like
4970 -- where F is a build-in-place function call returning a controlled
4971 -- type, then a temporary object will be implicitly declared as part
4972 -- of the statement list, and this will need cleanup. In such cases,
4975 -- return Result : T := ... do
4976 -- <statements> -- possibly with handlers
4981 -- return Result : T := ... do
4982 -- declare -- no declarations
4984 -- <statements> -- possibly with handlers
4985 -- end; -- no handlers
4988 -- So Expand_Cleanup_Actions will end up being called recursively on the
4991 if Nkind
(N
) = N_Extended_Return_Statement
then
4993 Block
: constant Node_Id
:=
4994 Make_Block_Statement
(Sloc
(N
),
4995 Declarations
=> Empty_List
,
4996 Handled_Statement_Sequence
=>
4997 Handled_Statement_Sequence
(N
));
4999 Set_Handled_Statement_Sequence
(N
,
5000 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
5001 Statements
=> New_List
(Block
)));
5006 -- Analysis of the block did all the work
5011 if Needs_Custom_Cleanup
then
5012 Cln
:= Cleanup_Actions
(N
);
5017 if No
(Declarations
(N
)) then
5018 Set_Declarations
(N
, New_List
);
5022 Decls
: constant List_Id
:= Declarations
(N
);
5024 Mark
: Entity_Id
:= Empty
;
5026 -- If we are generating expanded code for debugging purposes, use the
5027 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5028 -- be updated subsequently to reference the proper line in .dg files.
5029 -- If we are not debugging generated code, use No_Location instead,
5030 -- so that no debug information is generated for the cleanup code.
5031 -- This makes the behavior of the NEXT command in GDB monotonic, and
5032 -- makes the placement of breakpoints more accurate.
5034 if Debug_Generated_Code
then
5040 -- A task activation call has already been built for a task
5041 -- allocation block.
5043 if not Is_Task_Allocation
then
5044 Build_Task_Activation_Call
(N
);
5048 Establish_Task_Master
(N
);
5051 -- If secondary stack is in use, generate:
5053 -- Mnn : constant Mark_Id := SS_Mark;
5055 if Needs_Sec_Stack_Mark
then
5056 Set_Uses_Sec_Stack
(Scop
, False); -- avoid duplicate SS marks
5057 Mark
:= Make_Temporary
(Loc
, 'M');
5060 Mark_Call
: constant Node_Id
:= Build_SS_Mark_Call
(Loc
, Mark
);
5062 Prepend_To
(Decls
, Mark_Call
);
5063 Analyze
(Mark_Call
);
5067 -- Generate finalization calls for all controlled objects appearing
5068 -- in the statements of N. Add context specific cleanup for various
5073 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5076 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5080 if Present
(Fin_Id
) then
5081 Build_Finalizer_Call
(N
, Fin_Id
);
5084 end Expand_Cleanup_Actions
;
5086 ---------------------------
5087 -- Expand_N_Package_Body --
5088 ---------------------------
5090 -- Add call to Activate_Tasks if body is an activator (actual processing
5091 -- is in chapter 9).
5093 -- Generate subprogram descriptor for elaboration routine
5095 -- Encode entity names in package body
5097 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5098 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5099 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5104 -- This is done only for non-generic packages
5106 if Ekind
(Spec_Id
) = E_Package
then
5107 -- Build dispatch tables of library-level tagged types for bodies
5108 -- that are not compilation units (see Analyze_Compilation_Unit),
5109 -- except for instances because they have no N_Compilation_Unit.
5111 if Tagged_Type_Expansion
5112 and then Is_Library_Level_Entity
(Spec_Id
)
5113 and then (not Is_Compilation_Unit
(Spec_Id
)
5114 or else Is_Generic_Instance
(Spec_Id
))
5116 Build_Static_Dispatch_Tables
(N
);
5119 Push_Scope
(Spec_Id
);
5121 Expand_CUDA_Package
(N
);
5123 Build_Task_Activation_Call
(N
);
5125 -- Verify the run-time semantics of pragma Initial_Condition at the
5126 -- end of the body statements.
5128 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5130 -- If this is a library-level package and unnesting is enabled,
5131 -- check for the presence of blocks with nested subprograms occurring
5132 -- in elaboration code, and generate procedures to encapsulate the
5133 -- blocks in case the nested subprograms make up-level references.
5135 if Unnest_Subprogram_Mode
5137 Is_Library_Level_Entity
(Current_Scope
)
5139 Check_Unnesting_Elaboration_Code
(N
);
5140 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5141 Check_Unnesting_In_Handlers
(N
);
5147 Set_Elaboration_Flag
(N
, Spec_Id
);
5148 Set_In_Package_Body
(Spec_Id
, False);
5150 -- Set to encode entity names in package body before gigi is called
5152 Qualify_Entity_Names
(N
);
5154 if Ekind
(Spec_Id
) /= E_Generic_Package
5155 and then not Delay_Cleanups
(Id
)
5159 Clean_Stmts
=> No_List
,
5161 Top_Decls
=> No_List
,
5162 Defer_Abort
=> False,
5165 if Present
(Fin_Id
) then
5166 Set_Finalizer
(Defining_Entity
(N
), Fin_Id
);
5169 end Expand_N_Package_Body
;
5171 ----------------------------------
5172 -- Expand_N_Package_Declaration --
5173 ----------------------------------
5175 -- Add call to Activate_Tasks if there are tasks declared and the package
5176 -- has no body. Note that in Ada 83 this may result in premature activation
5177 -- of some tasks, given that we cannot tell whether a body will eventually
5180 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5181 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5182 Spec
: constant Node_Id
:= Specification
(N
);
5186 No_Body
: Boolean := False;
5187 -- True in the case of a package declaration that is a compilation
5188 -- unit and for which no associated body will be compiled in this
5192 -- Case of a package declaration other than a compilation unit
5194 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5197 -- Case of a compilation unit that does not require a body
5199 elsif not Body_Required
(Parent
(N
))
5200 and then not Unit_Requires_Body
(Id
)
5204 -- Special case of generating calling stubs for a remote call interface
5205 -- package: even though the package declaration requires one, the body
5206 -- won't be processed in this compilation (so any stubs for RACWs
5207 -- declared in the package must be generated here, along with the spec).
5209 elsif Parent
(N
) = Cunit
(Main_Unit
)
5210 and then Is_Remote_Call_Interface
(Id
)
5211 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5216 -- For a nested instance, delay processing until freeze point
5218 if Has_Delayed_Freeze
(Id
)
5219 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5224 -- For a package declaration that implies no associated body, generate
5225 -- task activation call and RACW supporting bodies now (since we won't
5226 -- have a specific separate compilation unit for that).
5231 -- Generate RACW subprogram bodies
5233 if Has_RACW
(Id
) then
5234 Decls
:= Private_Declarations
(Spec
);
5237 Decls
:= Visible_Declarations
(Spec
);
5242 Set_Visible_Declarations
(Spec
, Decls
);
5245 Append_RACW_Bodies
(Decls
, Id
);
5246 Analyze_List
(Decls
);
5249 -- Generate task activation call as last step of elaboration
5251 if Present
(Activation_Chain_Entity
(N
)) then
5252 Build_Task_Activation_Call
(N
);
5255 -- Verify the run-time semantics of pragma Initial_Condition at the
5256 -- end of the private declarations when the package lacks a body.
5258 Expand_Pragma_Initial_Condition
(Id
, N
);
5263 -- Build dispatch tables of library-level tagged types for instances
5264 -- that are not compilation units (see Analyze_Compilation_Unit).
5266 if Tagged_Type_Expansion
5267 and then Is_Library_Level_Entity
(Id
)
5268 and then Is_Generic_Instance
(Id
)
5269 and then not Is_Compilation_Unit
(Id
)
5271 Build_Static_Dispatch_Tables
(N
);
5274 -- Note: it is not necessary to worry about generating a subprogram
5275 -- descriptor, since the only way to get exception handlers into a
5276 -- package spec is to include instantiations, and that would cause
5277 -- generation of subprogram descriptors to be delayed in any case.
5279 -- Set to encode entity names in package spec before gigi is called
5281 Qualify_Entity_Names
(N
);
5283 if Ekind
(Id
) /= E_Generic_Package
5284 and then not Delay_Cleanups
(Id
)
5288 Clean_Stmts
=> No_List
,
5290 Top_Decls
=> No_List
,
5291 Defer_Abort
=> False,
5294 if Present
(Fin_Id
) then
5295 Set_Finalizer
(Id
, Fin_Id
);
5299 -- If this is a library-level package and unnesting is enabled,
5300 -- check for the presence of blocks with nested subprograms occurring
5301 -- in elaboration code, and generate procedures to encapsulate the
5302 -- blocks in case the nested subprograms make up-level references.
5304 if Unnest_Subprogram_Mode
5305 and then Is_Library_Level_Entity
(Current_Scope
)
5307 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
5308 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
5310 end Expand_N_Package_Declaration
;
5312 ---------------------------------
5313 -- Has_Simple_Protected_Object --
5314 ---------------------------------
5316 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5318 if Has_Task
(T
) then
5321 elsif Is_Simple_Protected_Type
(T
) then
5324 elsif Is_Array_Type
(T
) then
5325 return Has_Simple_Protected_Object
(Component_Type
(T
));
5327 elsif Is_Record_Type
(T
) then
5332 Comp
:= First_Component
(T
);
5333 while Present
(Comp
) loop
5334 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5338 Next_Component
(Comp
);
5347 end Has_Simple_Protected_Object
;
5349 ------------------------------------
5350 -- Insert_Actions_In_Scope_Around --
5351 ------------------------------------
5353 procedure Insert_Actions_In_Scope_Around
5356 Manage_SS
: Boolean)
5358 Act_Before
: constant List_Id
:=
5359 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5360 Act_After
: constant List_Id
:=
5361 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5362 Act_Cleanup
: constant List_Id
:=
5363 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5364 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5365 -- Last), but this was incorrect as Process_Transients_In_Scope may
5366 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5368 procedure Process_Transients_In_Scope
5369 (First_Object
: Node_Id
;
5370 Last_Object
: Node_Id
;
5371 Related_Node
: Node_Id
);
5372 -- Find all transient objects in the list First_Object .. Last_Object
5373 -- and generate finalization actions for them. Related_Node denotes the
5374 -- node which created all transient objects.
5376 ---------------------------------
5377 -- Process_Transients_In_Scope --
5378 ---------------------------------
5380 procedure Process_Transients_In_Scope
5381 (First_Object
: Node_Id
;
5382 Last_Object
: Node_Id
;
5383 Related_Node
: Node_Id
)
5385 Must_Hook
: Boolean;
5386 -- Flag denoting whether the context requires transient object
5387 -- export to the outer finalizer.
5389 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5390 -- Return Abandon if arbitrary node denotes a subprogram call
5392 function Has_Subprogram_Call
is
5393 new Traverse_Func
(Is_Subprogram_Call
);
5395 procedure Process_Transient_In_Scope
5396 (Obj_Decl
: Node_Id
;
5397 Blk_Data
: Finalization_Exception_Data
;
5398 Blk_Stmts
: List_Id
);
5399 -- Generate finalization actions for a single transient object
5400 -- denoted by object declaration Obj_Decl. Blk_Data is the
5401 -- exception data of the enclosing block. Blk_Stmts denotes the
5402 -- statements of the enclosing block.
5404 ------------------------
5405 -- Is_Subprogram_Call --
5406 ------------------------
5408 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5410 -- A regular procedure or function call
5412 if Nkind
(N
) in N_Subprogram_Call
then
5417 -- Heavy expansion may relocate function calls outside the related
5418 -- node. Inspect the original node to detect the initial placement
5421 elsif Is_Rewrite_Substitution
(N
) then
5422 return Has_Subprogram_Call
(Original_Node
(N
));
5424 -- Generalized indexing always involves a function call
5426 elsif Nkind
(N
) = N_Indexed_Component
5427 and then Present
(Generalized_Indexing
(N
))
5436 end Is_Subprogram_Call
;
5438 --------------------------------
5439 -- Process_Transient_In_Scope --
5440 --------------------------------
5442 procedure Process_Transient_In_Scope
5443 (Obj_Decl
: Node_Id
;
5444 Blk_Data
: Finalization_Exception_Data
;
5445 Blk_Stmts
: List_Id
)
5447 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5448 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5450 Fin_Stmts
: List_Id
;
5451 Hook_Assign
: Node_Id
;
5452 Hook_Clear
: Node_Id
;
5453 Hook_Decl
: Node_Id
;
5454 Hook_Insert
: Node_Id
;
5458 -- Mark the transient object as successfully processed to avoid
5459 -- double finalization.
5461 Set_Is_Finalized_Transient
(Obj_Id
);
5463 -- Construct all the pieces necessary to hook and finalize the
5464 -- transient object.
5466 Build_Transient_Object_Statements
5467 (Obj_Decl
=> Obj_Decl
,
5468 Fin_Call
=> Fin_Call
,
5469 Hook_Assign
=> Hook_Assign
,
5470 Hook_Clear
=> Hook_Clear
,
5471 Hook_Decl
=> Hook_Decl
,
5472 Ptr_Decl
=> Ptr_Decl
);
5474 -- The context contains at least one subprogram call which may
5475 -- raise an exception. This scenario employs "hooking" to pass
5476 -- transient objects to the enclosing finalizer in case of an
5481 -- Add the access type which provides a reference to the
5482 -- transient object. Generate:
5484 -- type Ptr_Typ is access all Desig_Typ;
5486 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5488 -- Add the temporary which acts as a hook to the transient
5489 -- object. Generate:
5491 -- Hook : Ptr_Typ := null;
5493 Insert_Action
(Obj_Decl
, Hook_Decl
);
5495 -- When the transient object is initialized by an aggregate,
5496 -- the hook must capture the object after the last aggregate
5497 -- assignment takes place. Only then is the object considered
5498 -- fully initialized. Generate:
5500 -- Hook := Ptr_Typ (Obj_Id);
5502 -- Hook := Obj_Id'Unrestricted_Access;
5504 -- Similarly if we have a build in place call: we must
5505 -- initialize Hook only after the call has happened, otherwise
5506 -- Obj_Id will not be initialized yet.
5508 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
5509 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
5510 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5511 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
5512 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
5514 Hook_Insert
:= Obj_Decl
;
5517 -- Otherwise the hook seizes the related object immediately
5520 Hook_Insert
:= Obj_Decl
;
5523 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5526 -- When exception propagation is enabled wrap the hook clear
5527 -- statement and the finalization call into a block to catch
5528 -- potential exceptions raised during finalization. Generate:
5532 -- [Deep_]Finalize (Obj_Ref);
5536 -- if not Raised then
5539 -- (Enn, Get_Current_Excep.all.all);
5543 if Exceptions_OK
then
5544 Fin_Stmts
:= New_List
;
5547 Append_To
(Fin_Stmts
, Hook_Clear
);
5550 Append_To
(Fin_Stmts
, Fin_Call
);
5552 Prepend_To
(Blk_Stmts
,
5553 Make_Block_Statement
(Loc
,
5554 Handled_Statement_Sequence
=>
5555 Make_Handled_Sequence_Of_Statements
(Loc
,
5556 Statements
=> Fin_Stmts
,
5557 Exception_Handlers
=> New_List
(
5558 Build_Exception_Handler
(Blk_Data
)))));
5560 -- Otherwise generate:
5563 -- [Deep_]Finalize (Obj_Ref);
5565 -- Note that the statements are inserted in reverse order to
5566 -- achieve the desired final order outlined above.
5569 Prepend_To
(Blk_Stmts
, Fin_Call
);
5572 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5575 end Process_Transient_In_Scope
;
5579 Built
: Boolean := False;
5580 Blk_Data
: Finalization_Exception_Data
;
5581 Blk_Decl
: Node_Id
:= Empty
;
5582 Blk_Decls
: List_Id
:= No_List
;
5584 Blk_Stmts
: List_Id
:= No_List
;
5585 Loc
: Source_Ptr
:= No_Location
;
5588 -- Start of processing for Process_Transients_In_Scope
5591 -- The expansion performed by this routine is as follows:
5593 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5594 -- Hook_1 : Ptr_Typ_1 := null;
5595 -- Ctrl_Trans_Obj_1 : ...;
5596 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5598 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5599 -- Hook_N : Ptr_Typ_N := null;
5600 -- Ctrl_Trans_Obj_N : ...;
5601 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5604 -- Abrt : constant Boolean := ...;
5605 -- Ex : Exception_Occurrence;
5606 -- Raised : Boolean := False;
5613 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5617 -- if not Raised then
5619 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5624 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5628 -- if not Raised then
5630 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5635 -- if Raised and not Abrt then
5636 -- Raise_From_Controlled_Operation (Ex);
5640 -- Recognize a scenario where the transient context is an object
5641 -- declaration initialized by a build-in-place function call:
5643 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5645 -- The rough expansion of the above is:
5647 -- Temp : ... := Ctrl_Func_Call;
5649 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5651 -- The finalization of any transient object must happen after the
5652 -- build-in-place function call is executed.
5654 if Nkind
(N
) = N_Object_Declaration
5655 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5658 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5660 -- Search the context for at least one subprogram call. If found, the
5661 -- machinery exports all transient objects to the enclosing finalizer
5662 -- due to the possibility of abnormal call termination.
5665 Must_Hook
:= Has_Subprogram_Call
(N
) = Abandon
;
5666 Blk_Ins
:= Last_Object
;
5669 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5671 -- Examine all objects in the list First_Object .. Last_Object
5673 Obj_Decl
:= First_Object
;
5674 while Present
(Obj_Decl
) loop
5675 if Nkind
(Obj_Decl
) = N_Object_Declaration
5676 and then Analyzed
(Obj_Decl
)
5677 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5679 -- Do not process the node to be wrapped since it will be
5680 -- handled by the enclosing finalizer.
5682 and then Obj_Decl
/= Related_Node
5684 Loc
:= Sloc
(Obj_Decl
);
5686 -- Before generating the cleanup code for the first transient
5687 -- object, create a wrapper block which houses all hook clear
5688 -- statements and finalization calls. This wrapper is needed by
5693 Blk_Stmts
:= New_List
;
5696 -- Abrt : constant Boolean := ...;
5697 -- Ex : Exception_Occurrence;
5698 -- Raised : Boolean := False;
5700 if Exceptions_OK
then
5701 Blk_Decls
:= New_List
;
5702 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5706 Make_Block_Statement
(Loc
,
5707 Declarations
=> Blk_Decls
,
5708 Handled_Statement_Sequence
=>
5709 Make_Handled_Sequence_Of_Statements
(Loc
,
5710 Statements
=> Blk_Stmts
));
5713 -- Construct all necessary circuitry to hook and finalize a
5714 -- single transient object.
5716 pragma Assert
(Present
(Blk_Stmts
));
5717 Process_Transient_In_Scope
5718 (Obj_Decl
=> Obj_Decl
,
5719 Blk_Data
=> Blk_Data
,
5720 Blk_Stmts
=> Blk_Stmts
);
5723 -- Terminate the scan after the last object has been processed to
5724 -- avoid touching unrelated code.
5726 if Obj_Decl
= Last_Object
then
5733 -- Complete the decoration of the enclosing finalization block and
5734 -- insert it into the tree.
5736 if Present
(Blk_Decl
) then
5738 pragma Assert
(Present
(Blk_Stmts
));
5739 pragma Assert
(Loc
/= No_Location
);
5741 -- Note that this Abort_Undefer does not require a extra block or
5742 -- an AT_END handler because each finalization exception is caught
5743 -- in its own corresponding finalization block. As a result, the
5744 -- call to Abort_Defer always takes place.
5746 if Abort_Allowed
then
5747 Prepend_To
(Blk_Stmts
,
5748 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5750 Append_To
(Blk_Stmts
,
5751 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5755 -- if Raised and then not Abrt then
5756 -- Raise_From_Controlled_Operation (Ex);
5759 if Exceptions_OK
then
5760 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5763 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5765 end Process_Transients_In_Scope
;
5769 Loc
: constant Source_Ptr
:= Sloc
(N
);
5770 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5771 First_Obj
: Node_Id
;
5773 Mark_Id
: Entity_Id
;
5776 -- Start of processing for Insert_Actions_In_Scope_Around
5779 -- Nothing to do if the scope does not manage the secondary stack or
5780 -- does not contain meaningful actions for insertion.
5783 and then No
(Act_Before
)
5784 and then No
(Act_After
)
5785 and then No
(Act_Cleanup
)
5790 -- If the node to be wrapped is the trigger of an asynchronous select,
5791 -- it is not part of a statement list. The actions must be inserted
5792 -- before the select itself, which is part of some list of statements.
5793 -- Note that the triggering alternative includes the triggering
5794 -- statement and an optional statement list. If the node to be
5795 -- wrapped is part of that list, the normal insertion applies.
5797 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5798 and then not Is_List_Member
(Node_To_Wrap
)
5800 Target
:= Parent
(Parent
(Node_To_Wrap
));
5805 First_Obj
:= Target
;
5808 -- Add all actions associated with a transient scope into the main tree.
5809 -- There are several scenarios here:
5811 -- +--- Before ----+ +----- After ---+
5812 -- 1) First_Obj ....... Target ........ Last_Obj
5814 -- 2) First_Obj ....... Target
5816 -- 3) Target ........ Last_Obj
5818 -- Flag declarations are inserted before the first object
5820 if Present
(Act_Before
) then
5821 First_Obj
:= First
(Act_Before
);
5822 Insert_List_Before
(Target
, Act_Before
);
5825 -- Finalization calls are inserted after the last object
5827 if Present
(Act_After
) then
5828 Last_Obj
:= Last
(Act_After
);
5829 Insert_List_After
(Target
, Act_After
);
5832 -- Mark and release the secondary stack when the context warrants it
5835 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5838 -- Mnn : constant Mark_Id := SS_Mark;
5840 Insert_Before_And_Analyze
5841 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5844 -- SS_Release (Mnn);
5846 Insert_After_And_Analyze
5847 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5850 -- If we are handling cleanups, check for transient objects associated
5851 -- with Target and generate the required finalization actions for them.
5854 Process_Transients_In_Scope
5855 (First_Object
=> First_Obj
,
5856 Last_Object
=> Last_Obj
,
5857 Related_Node
=> Target
);
5860 -- Reset the action lists
5863 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5865 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5869 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5871 end Insert_Actions_In_Scope_Around
;
5873 ------------------------------
5874 -- Is_Simple_Protected_Type --
5875 ------------------------------
5877 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5880 Is_Protected_Type
(T
)
5881 and then not Uses_Lock_Free
(T
)
5882 and then not Has_Entries
(T
)
5883 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5884 end Is_Simple_Protected_Type
;
5886 -----------------------
5887 -- Make_Adjust_Call --
5888 -----------------------
5890 function Make_Adjust_Call
5893 Skip_Self
: Boolean := False) return Node_Id
5895 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5896 Adj_Id
: Entity_Id
:= Empty
;
5903 -- Recover the proper type which contains Deep_Adjust
5905 if Is_Class_Wide_Type
(Typ
) then
5906 Utyp
:= Root_Type
(Typ
);
5911 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5912 Set_Assignment_OK
(Ref
);
5914 -- Deal with untagged derivation of private views
5916 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5917 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5918 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5919 Set_Assignment_OK
(Ref
);
5922 -- When dealing with the completion of a private type, use the base
5925 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5926 pragma Assert
(Is_Private_Type
(Typ
));
5928 Utyp
:= Base_Type
(Utyp
);
5929 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5932 -- The underlying type may not be present due to a missing full view. In
5933 -- this case freezing did not take place and there is no [Deep_]Adjust
5934 -- primitive to call.
5939 elsif Skip_Self
then
5940 if Has_Controlled_Component
(Utyp
) then
5941 if Is_Tagged_Type
(Utyp
) then
5942 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5944 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5948 -- Class-wide types, interfaces and types with controlled components
5950 elsif Is_Class_Wide_Type
(Typ
)
5951 or else Is_Interface
(Typ
)
5952 or else Has_Controlled_Component
(Utyp
)
5954 if Is_Tagged_Type
(Utyp
) then
5955 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5957 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5960 -- Derivations from [Limited_]Controlled
5962 elsif Is_Controlled
(Utyp
) then
5963 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5967 elsif Is_Tagged_Type
(Utyp
) then
5968 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5971 raise Program_Error
;
5974 if Present
(Adj_Id
) then
5976 -- If the object is unanalyzed, set its expected type for use in
5977 -- Convert_View in case an additional conversion is needed.
5980 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5982 Set_Etype
(Ref
, Typ
);
5985 -- The object reference may need another conversion depending on the
5986 -- type of the formal and that of the actual.
5988 if not Is_Class_Wide_Type
(Typ
) then
5989 Ref
:= Convert_View
(Adj_Id
, Ref
);
5996 Skip_Self
=> Skip_Self
);
6000 end Make_Adjust_Call
;
6008 Proc_Id
: Entity_Id
;
6010 Skip_Self
: Boolean := False) return Node_Id
6012 Params
: constant List_Id
:= New_List
(Param
);
6015 -- Do not apply the controlled action to the object itself by signaling
6016 -- the related routine to avoid self.
6019 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6023 Make_Procedure_Call_Statement
(Loc
,
6024 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6025 Parameter_Associations
=> Params
);
6028 --------------------------
6029 -- Make_Deep_Array_Body --
6030 --------------------------
6032 function Make_Deep_Array_Body
6033 (Prim
: Final_Primitives
;
6034 Typ
: Entity_Id
) return List_Id
6036 function Build_Adjust_Or_Finalize_Statements
6037 (Typ
: Entity_Id
) return List_Id
;
6038 -- Create the statements necessary to adjust or finalize an array of
6039 -- controlled elements. Generate:
6042 -- Abort : constant Boolean := Triggered_By_Abort;
6044 -- Abort : constant Boolean := False; -- no abort
6046 -- E : Exception_Occurrence;
6047 -- Raised : Boolean := False;
6050 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6051 -- ^-- in the finalization case
6053 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6055 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6059 -- if not Raised then
6061 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6068 -- if Raised and then not Abort then
6069 -- Raise_From_Controlled_Operation (E);
6073 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6074 -- Create the statements necessary to initialize an array of controlled
6075 -- elements. Include a mechanism to carry out partial finalization if an
6076 -- exception occurs. Generate:
6079 -- Counter : Integer := 0;
6082 -- for J1 in V'Range (1) loop
6084 -- for JN in V'Range (N) loop
6086 -- [Deep_]Initialize (V (J1, ..., JN));
6088 -- Counter := Counter + 1;
6093 -- Abort : constant Boolean := Triggered_By_Abort;
6095 -- Abort : constant Boolean := False; -- no abort
6096 -- E : Exception_Occurrence;
6097 -- Raised : Boolean := False;
6104 -- V'Length (N) - Counter;
6106 -- for F1 in reverse V'Range (1) loop
6108 -- for FN in reverse V'Range (N) loop
6109 -- if Counter > 0 then
6110 -- Counter := Counter - 1;
6113 -- [Deep_]Finalize (V (F1, ..., FN));
6117 -- if not Raised then
6119 -- Save_Occurrence (E,
6120 -- Get_Current_Excep.all.all);
6129 -- if Raised and then not Abort then
6130 -- Raise_From_Controlled_Operation (E);
6139 function New_References_To
6141 Loc
: Source_Ptr
) return List_Id
;
6142 -- Given a list of defining identifiers, return a list of references to
6143 -- the original identifiers, in the same order as they appear.
6145 -----------------------------------------
6146 -- Build_Adjust_Or_Finalize_Statements --
6147 -----------------------------------------
6149 function Build_Adjust_Or_Finalize_Statements
6150 (Typ
: Entity_Id
) return List_Id
6152 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6153 Index_List
: constant List_Id
:= New_List
;
6154 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6155 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6157 procedure Build_Indexes
;
6158 -- Generate the indexes used in the dimension loops
6164 procedure Build_Indexes
is
6166 -- Generate the following identifiers:
6167 -- Jnn - for initialization
6169 for Dim
in 1 .. Num_Dims
loop
6170 Append_To
(Index_List
,
6171 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6177 Final_Decls
: List_Id
:= No_List
;
6178 Final_Data
: Finalization_Exception_Data
;
6182 Core_Loop
: Node_Id
;
6185 Loop_Id
: Entity_Id
;
6188 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6191 Final_Decls
:= New_List
;
6194 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6197 Make_Indexed_Component
(Loc
,
6198 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6199 Expressions
=> New_References_To
(Index_List
, Loc
));
6200 Set_Etype
(Comp_Ref
, Comp_Typ
);
6203 -- [Deep_]Adjust (V (J1, ..., JN))
6205 if Prim
= Adjust_Case
then
6206 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6209 -- [Deep_]Finalize (V (J1, ..., JN))
6211 else pragma Assert
(Prim
= Finalize_Case
);
6212 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6215 if Present
(Call
) then
6217 -- Generate the block which houses the adjust or finalize call:
6220 -- <adjust or finalize call>
6224 -- if not Raised then
6226 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6230 if Exceptions_OK
then
6232 Make_Block_Statement
(Loc
,
6233 Handled_Statement_Sequence
=>
6234 Make_Handled_Sequence_Of_Statements
(Loc
,
6235 Statements
=> New_List
(Call
),
6236 Exception_Handlers
=> New_List
(
6237 Build_Exception_Handler
(Final_Data
))));
6242 -- Generate the dimension loops starting from the innermost one
6244 -- for Jnn in [reverse] V'Range (Dim) loop
6248 J
:= Last
(Index_List
);
6250 while Present
(J
) and then Dim
> 0 loop
6256 Make_Loop_Statement
(Loc
,
6258 Make_Iteration_Scheme
(Loc
,
6259 Loop_Parameter_Specification
=>
6260 Make_Loop_Parameter_Specification
(Loc
,
6261 Defining_Identifier
=> Loop_Id
,
6262 Discrete_Subtype_Definition
=>
6263 Make_Attribute_Reference
(Loc
,
6264 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6265 Attribute_Name
=> Name_Range
,
6266 Expressions
=> New_List
(
6267 Make_Integer_Literal
(Loc
, Dim
))),
6270 Prim
= Finalize_Case
)),
6272 Statements
=> New_List
(Core_Loop
),
6273 End_Label
=> Empty
);
6278 -- Generate the block which contains the core loop, declarations
6279 -- of the abort flag, the exception occurrence, the raised flag
6280 -- and the conditional raise:
6283 -- Abort : constant Boolean := Triggered_By_Abort;
6285 -- Abort : constant Boolean := False; -- no abort
6287 -- E : Exception_Occurrence;
6288 -- Raised : Boolean := False;
6293 -- if Raised and then not Abort then
6294 -- Raise_From_Controlled_Operation (E);
6298 Stmts
:= New_List
(Core_Loop
);
6300 if Exceptions_OK
then
6301 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6305 Make_Block_Statement
(Loc
,
6306 Declarations
=> Final_Decls
,
6307 Handled_Statement_Sequence
=>
6308 Make_Handled_Sequence_Of_Statements
(Loc
,
6309 Statements
=> Stmts
));
6311 -- Otherwise previous errors or a missing full view may prevent the
6312 -- proper freezing of the component type. If this is the case, there
6313 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6316 Block
:= Make_Null_Statement
(Loc
);
6319 return New_List
(Block
);
6320 end Build_Adjust_Or_Finalize_Statements
;
6322 ---------------------------------
6323 -- Build_Initialize_Statements --
6324 ---------------------------------
6326 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6327 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6328 Final_List
: constant List_Id
:= New_List
;
6329 Index_List
: constant List_Id
:= New_List
;
6330 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6331 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6333 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6334 -- Generate the following assignment:
6335 -- Counter := V'Length (1) *
6337 -- V'Length (N) - Counter;
6339 -- Counter_Id denotes the entity of the counter.
6341 function Build_Finalization_Call
return Node_Id
;
6342 -- Generate a deep finalization call for an array element
6344 procedure Build_Indexes
;
6345 -- Generate the initialization and finalization indexes used in the
6348 function Build_Initialization_Call
return Node_Id
;
6349 -- Generate a deep initialization call for an array element
6351 ----------------------
6352 -- Build_Assignment --
6353 ----------------------
6355 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6360 -- Start from the first dimension and generate:
6365 Make_Attribute_Reference
(Loc
,
6366 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6367 Attribute_Name
=> Name_Length
,
6368 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6370 -- Process the rest of the dimensions, generate:
6371 -- Expr * V'Length (N)
6374 while Dim
<= Num_Dims
loop
6376 Make_Op_Multiply
(Loc
,
6379 Make_Attribute_Reference
(Loc
,
6380 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6381 Attribute_Name
=> Name_Length
,
6382 Expressions
=> New_List
(
6383 Make_Integer_Literal
(Loc
, Dim
))));
6389 -- Counter := Expr - Counter;
6392 Make_Assignment_Statement
(Loc
,
6393 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6395 Make_Op_Subtract
(Loc
,
6397 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6398 end Build_Assignment
;
6400 -----------------------------
6401 -- Build_Finalization_Call --
6402 -----------------------------
6404 function Build_Finalization_Call
return Node_Id
is
6405 Comp_Ref
: constant Node_Id
:=
6406 Make_Indexed_Component
(Loc
,
6407 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6408 Expressions
=> New_References_To
(Final_List
, Loc
));
6411 Set_Etype
(Comp_Ref
, Comp_Typ
);
6414 -- [Deep_]Finalize (V);
6416 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6417 end Build_Finalization_Call
;
6423 procedure Build_Indexes
is
6425 -- Generate the following identifiers:
6426 -- Jnn - for initialization
6427 -- Fnn - for finalization
6429 for Dim
in 1 .. Num_Dims
loop
6430 Append_To
(Index_List
,
6431 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6433 Append_To
(Final_List
,
6434 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6438 -------------------------------
6439 -- Build_Initialization_Call --
6440 -------------------------------
6442 function Build_Initialization_Call
return Node_Id
is
6443 Comp_Ref
: constant Node_Id
:=
6444 Make_Indexed_Component
(Loc
,
6445 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6446 Expressions
=> New_References_To
(Index_List
, Loc
));
6449 Set_Etype
(Comp_Ref
, Comp_Typ
);
6452 -- [Deep_]Initialize (V (J1, ..., JN));
6454 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6455 end Build_Initialization_Call
;
6459 Counter_Id
: Entity_Id
;
6463 Final_Block
: Node_Id
;
6464 Final_Data
: Finalization_Exception_Data
;
6465 Final_Decls
: List_Id
:= No_List
;
6466 Final_Loop
: Node_Id
;
6467 Init_Block
: Node_Id
;
6468 Init_Call
: Node_Id
;
6469 Init_Loop
: Node_Id
;
6474 -- Start of processing for Build_Initialize_Statements
6477 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6478 Final_Decls
:= New_List
;
6481 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6483 -- Generate the block which houses the finalization call, the index
6484 -- guard and the handler which triggers Program_Error later on.
6486 -- if Counter > 0 then
6487 -- Counter := Counter - 1;
6490 -- [Deep_]Finalize (V (F1, ..., FN));
6493 -- if not Raised then
6495 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6500 Fin_Stmt
:= Build_Finalization_Call
;
6502 if Present
(Fin_Stmt
) then
6503 if Exceptions_OK
then
6505 Make_Block_Statement
(Loc
,
6506 Handled_Statement_Sequence
=>
6507 Make_Handled_Sequence_Of_Statements
(Loc
,
6508 Statements
=> New_List
(Fin_Stmt
),
6509 Exception_Handlers
=> New_List
(
6510 Build_Exception_Handler
(Final_Data
))));
6513 -- This is the core of the loop, the dimension iterators are added
6514 -- one by one in reverse.
6517 Make_If_Statement
(Loc
,
6520 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6521 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6523 Then_Statements
=> New_List
(
6524 Make_Assignment_Statement
(Loc
,
6525 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6527 Make_Op_Subtract
(Loc
,
6528 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6529 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6531 Else_Statements
=> New_List
(Fin_Stmt
));
6533 -- Generate all finalization loops starting from the innermost
6536 -- for Fnn in reverse V'Range (Dim) loop
6540 F
:= Last
(Final_List
);
6542 while Present
(F
) and then Dim
> 0 loop
6548 Make_Loop_Statement
(Loc
,
6550 Make_Iteration_Scheme
(Loc
,
6551 Loop_Parameter_Specification
=>
6552 Make_Loop_Parameter_Specification
(Loc
,
6553 Defining_Identifier
=> Loop_Id
,
6554 Discrete_Subtype_Definition
=>
6555 Make_Attribute_Reference
(Loc
,
6556 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6557 Attribute_Name
=> Name_Range
,
6558 Expressions
=> New_List
(
6559 Make_Integer_Literal
(Loc
, Dim
))),
6561 Reverse_Present
=> True)),
6563 Statements
=> New_List
(Final_Loop
),
6564 End_Label
=> Empty
);
6569 -- Generate the block which contains the finalization loops, the
6570 -- declarations of the abort flag, the exception occurrence, the
6571 -- raised flag and the conditional raise.
6574 -- Abort : constant Boolean := Triggered_By_Abort;
6576 -- Abort : constant Boolean := False; -- no abort
6578 -- E : Exception_Occurrence;
6579 -- Raised : Boolean := False;
6585 -- V'Length (N) - Counter;
6589 -- if Raised and then not Abort then
6590 -- Raise_From_Controlled_Operation (E);
6596 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6598 if Exceptions_OK
then
6599 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6600 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6604 Make_Block_Statement
(Loc
,
6605 Declarations
=> Final_Decls
,
6606 Handled_Statement_Sequence
=>
6607 Make_Handled_Sequence_Of_Statements
(Loc
,
6608 Statements
=> Stmts
));
6610 -- Otherwise previous errors or a missing full view may prevent the
6611 -- proper freezing of the component type. If this is the case, there
6612 -- is no [Deep_]Finalize primitive to call.
6615 Final_Block
:= Make_Null_Statement
(Loc
);
6618 -- Generate the block which contains the initialization call and
6619 -- the partial finalization code.
6622 -- [Deep_]Initialize (V (J1, ..., JN));
6624 -- Counter := Counter + 1;
6628 -- <finalization code>
6631 Init_Call
:= Build_Initialization_Call
;
6633 -- Only create finalization block if there is a nontrivial call
6634 -- to initialization or a Default_Initial_Condition check to be
6637 if (Present
(Init_Call
)
6638 and then Nkind
(Init_Call
) /= N_Null_Statement
)
6641 and then not GNATprove_Mode
6642 and then Present
(DIC_Procedure
(Comp_Typ
))
6643 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
6646 Init_Stmts
: constant List_Id
:= New_List
;
6649 if Present
(Init_Call
) then
6650 Append_To
(Init_Stmts
, Init_Call
);
6653 if Has_DIC
(Comp_Typ
)
6654 and then Present
(DIC_Procedure
(Comp_Typ
))
6658 Build_DIC_Call
(Loc
,
6659 Make_Indexed_Component
(Loc
,
6660 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6661 Expressions
=> New_References_To
(Index_List
, Loc
)),
6666 Make_Block_Statement
(Loc
,
6667 Handled_Statement_Sequence
=>
6668 Make_Handled_Sequence_Of_Statements
(Loc
,
6669 Statements
=> Init_Stmts
,
6670 Exception_Handlers
=> New_List
(
6671 Make_Exception_Handler
(Loc
,
6672 Exception_Choices
=> New_List
(
6673 Make_Others_Choice
(Loc
)),
6674 Statements
=> New_List
(Final_Block
)))));
6677 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6678 Make_Assignment_Statement
(Loc
,
6679 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6682 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6683 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6685 -- Generate all initialization loops starting from the innermost
6688 -- for Jnn in V'Range (Dim) loop
6692 J
:= Last
(Index_List
);
6694 while Present
(J
) and then Dim
> 0 loop
6700 Make_Loop_Statement
(Loc
,
6702 Make_Iteration_Scheme
(Loc
,
6703 Loop_Parameter_Specification
=>
6704 Make_Loop_Parameter_Specification
(Loc
,
6705 Defining_Identifier
=> Loop_Id
,
6706 Discrete_Subtype_Definition
=>
6707 Make_Attribute_Reference
(Loc
,
6708 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6709 Attribute_Name
=> Name_Range
,
6710 Expressions
=> New_List
(
6711 Make_Integer_Literal
(Loc
, Dim
))))),
6713 Statements
=> New_List
(Init_Loop
),
6714 End_Label
=> Empty
);
6719 -- Generate the block which contains the counter variable and the
6720 -- initialization loops.
6723 -- Counter : Integer := 0;
6729 Make_Block_Statement
(Loc
,
6730 Declarations
=> New_List
(
6731 Make_Object_Declaration
(Loc
,
6732 Defining_Identifier
=> Counter_Id
,
6733 Object_Definition
=>
6734 New_Occurrence_Of
(Standard_Integer
, Loc
),
6735 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6737 Handled_Statement_Sequence
=>
6738 Make_Handled_Sequence_Of_Statements
(Loc
,
6739 Statements
=> New_List
(Init_Loop
)));
6741 if Debug_Generated_Code
then
6742 Set_Debug_Info_Needed
(Counter_Id
);
6745 -- Otherwise previous errors or a missing full view may prevent the
6746 -- proper freezing of the component type. If this is the case, there
6747 -- is no [Deep_]Initialize primitive to call.
6750 Init_Block
:= Make_Null_Statement
(Loc
);
6753 return New_List
(Init_Block
);
6754 end Build_Initialize_Statements
;
6756 -----------------------
6757 -- New_References_To --
6758 -----------------------
6760 function New_References_To
6762 Loc
: Source_Ptr
) return List_Id
6764 Refs
: constant List_Id
:= New_List
;
6769 while Present
(Id
) loop
6770 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6775 end New_References_To
;
6777 -- Start of processing for Make_Deep_Array_Body
6781 when Address_Case
=>
6782 return Make_Finalize_Address_Stmts
(Typ
);
6787 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6789 when Initialize_Case
=>
6790 return Build_Initialize_Statements
(Typ
);
6792 end Make_Deep_Array_Body
;
6794 --------------------
6795 -- Make_Deep_Proc --
6796 --------------------
6798 function Make_Deep_Proc
6799 (Prim
: Final_Primitives
;
6801 Stmts
: List_Id
) return Entity_Id
6803 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6805 Proc_Id
: Entity_Id
;
6808 -- Create the object formal, generate:
6809 -- V : System.Address
6811 if Prim
= Address_Case
then
6812 Formals
:= New_List
(
6813 Make_Parameter_Specification
(Loc
,
6814 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6816 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6823 Formals
:= New_List
(
6824 Make_Parameter_Specification
(Loc
,
6825 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6827 Out_Present
=> True,
6828 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6830 -- F : Boolean := True
6832 if Prim
= Adjust_Case
6833 or else Prim
= Finalize_Case
6836 Make_Parameter_Specification
(Loc
,
6837 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6839 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6841 New_Occurrence_Of
(Standard_True
, Loc
)));
6846 Make_Defining_Identifier
(Loc
,
6847 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6850 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6853 -- exception -- Finalize and Adjust cases only
6854 -- raise Program_Error;
6855 -- end Deep_Initialize / Adjust / Finalize;
6859 -- procedure Finalize_Address (V : System.Address) is
6862 -- end Finalize_Address;
6865 Make_Subprogram_Body
(Loc
,
6867 Make_Procedure_Specification
(Loc
,
6868 Defining_Unit_Name
=> Proc_Id
,
6869 Parameter_Specifications
=> Formals
),
6871 Declarations
=> Empty_List
,
6873 Handled_Statement_Sequence
=>
6874 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6876 -- If there are no calls to component initialization, indicate that
6877 -- the procedure is trivial, so prevent calls to it.
6879 if Is_Empty_List
(Stmts
)
6880 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6882 Set_Is_Trivial_Subprogram
(Proc_Id
);
6888 ---------------------------
6889 -- Make_Deep_Record_Body --
6890 ---------------------------
6892 function Make_Deep_Record_Body
6893 (Prim
: Final_Primitives
;
6895 Is_Local
: Boolean := False) return List_Id
6897 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6898 -- Build the statements necessary to adjust a record type. The type may
6899 -- have discriminants and contain variant parts. Generate:
6903 -- [Deep_]Adjust (V.Comp_1);
6905 -- when Id : others =>
6906 -- if not Raised then
6908 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6913 -- [Deep_]Adjust (V.Comp_N);
6915 -- when Id : others =>
6916 -- if not Raised then
6918 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6923 -- Deep_Adjust (V._parent, False); -- If applicable
6925 -- when Id : others =>
6926 -- if not Raised then
6928 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6934 -- Adjust (V); -- If applicable
6937 -- if not Raised then
6939 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6944 -- if Raised and then not Abort then
6945 -- Raise_From_Controlled_Operation (E);
6949 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6950 -- Build the statements necessary to finalize a record type. The type
6951 -- may have discriminants and contain variant parts. Generate:
6954 -- Abort : constant Boolean := Triggered_By_Abort;
6956 -- Abort : constant Boolean := False; -- no abort
6957 -- E : Exception_Occurrence;
6958 -- Raised : Boolean := False;
6963 -- Finalize (V); -- If applicable
6966 -- if not Raised then
6968 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6973 -- case Variant_1 is
6975 -- case State_Counter_N => -- If Is_Local is enabled
6985 -- <<LN>> -- If Is_Local is enabled
6987 -- [Deep_]Finalize (V.Comp_N);
6990 -- if not Raised then
6992 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6998 -- [Deep_]Finalize (V.Comp_1);
7001 -- if not Raised then
7003 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7009 -- case State_Counter_1 => -- If Is_Local is enabled
7015 -- Deep_Finalize (V._parent, False); -- If applicable
7017 -- when Id : others =>
7018 -- if not Raised then
7020 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7024 -- if Raised and then not Abort then
7025 -- Raise_From_Controlled_Operation (E);
7029 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7030 -- Given a derived tagged type Typ, traverse all components, find field
7031 -- _parent and return its type.
7033 procedure Preprocess_Components
7035 Num_Comps
: out Nat
;
7036 Has_POC
: out Boolean);
7037 -- Examine all components in component list Comps, count all controlled
7038 -- components and determine whether at least one of them is per-object
7039 -- constrained. Component _parent is always skipped.
7041 -----------------------------
7042 -- Build_Adjust_Statements --
7043 -----------------------------
7045 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7046 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7047 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7049 Finalizer_Data
: Finalization_Exception_Data
;
7051 function Process_Component_List_For_Adjust
7052 (Comps
: Node_Id
) return List_Id
;
7053 -- Build all necessary adjust statements for a single component list
7055 ---------------------------------------
7056 -- Process_Component_List_For_Adjust --
7057 ---------------------------------------
7059 function Process_Component_List_For_Adjust
7060 (Comps
: Node_Id
) return List_Id
7062 Stmts
: constant List_Id
:= New_List
;
7064 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7065 -- Process the declaration of a single controlled component
7067 ----------------------------------
7068 -- Process_Component_For_Adjust --
7069 ----------------------------------
7071 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7072 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7073 Typ
: constant Entity_Id
:= Etype
(Id
);
7079 -- [Deep_]Adjust (V.Id);
7083 -- if not Raised then
7085 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7092 Make_Selected_Component
(Loc
,
7093 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7094 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7097 -- Guard against a missing [Deep_]Adjust when the component
7098 -- type was not properly frozen.
7100 if Present
(Adj_Call
) then
7101 if Exceptions_OK
then
7103 Make_Block_Statement
(Loc
,
7104 Handled_Statement_Sequence
=>
7105 Make_Handled_Sequence_Of_Statements
(Loc
,
7106 Statements
=> New_List
(Adj_Call
),
7107 Exception_Handlers
=> New_List
(
7108 Build_Exception_Handler
(Finalizer_Data
))));
7111 Append_To
(Stmts
, Adj_Call
);
7113 end Process_Component_For_Adjust
;
7118 Decl_Id
: Entity_Id
;
7119 Decl_Typ
: Entity_Id
;
7124 -- Start of processing for Process_Component_List_For_Adjust
7127 -- Perform an initial check, determine the number of controlled
7128 -- components in the current list and whether at least one of them
7129 -- is per-object constrained.
7131 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7133 -- The processing in this routine is done in the following order:
7134 -- 1) Regular components
7135 -- 2) Per-object constrained components
7138 if Num_Comps
> 0 then
7140 -- Process all regular components in order of declarations
7142 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7143 while Present
(Decl
) loop
7144 Decl_Id
:= Defining_Identifier
(Decl
);
7145 Decl_Typ
:= Etype
(Decl_Id
);
7147 -- Skip _parent as well as per-object constrained components
7149 if Chars
(Decl_Id
) /= Name_uParent
7150 and then Needs_Finalization
(Decl_Typ
)
7152 if Has_Access_Constraint
(Decl_Id
)
7153 and then No
(Expression
(Decl
))
7157 Process_Component_For_Adjust
(Decl
);
7161 Next_Non_Pragma
(Decl
);
7164 -- Process all per-object constrained components in order of
7168 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7169 while Present
(Decl
) loop
7170 Decl_Id
:= Defining_Identifier
(Decl
);
7171 Decl_Typ
:= Etype
(Decl_Id
);
7175 if Chars
(Decl_Id
) /= Name_uParent
7176 and then Needs_Finalization
(Decl_Typ
)
7177 and then Has_Access_Constraint
(Decl_Id
)
7178 and then No
(Expression
(Decl
))
7180 Process_Component_For_Adjust
(Decl
);
7183 Next_Non_Pragma
(Decl
);
7188 -- Process all variants, if any
7191 if Present
(Variant_Part
(Comps
)) then
7193 Var_Alts
: constant List_Id
:= New_List
;
7197 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7198 while Present
(Var
) loop
7201 -- when <discrete choices> =>
7202 -- <adjust statements>
7204 Append_To
(Var_Alts
,
7205 Make_Case_Statement_Alternative
(Loc
,
7207 New_Copy_List
(Discrete_Choices
(Var
)),
7209 Process_Component_List_For_Adjust
(
7210 Component_List
(Var
))));
7212 Next_Non_Pragma
(Var
);
7216 -- case V.<discriminant> is
7217 -- when <discrete choices 1> =>
7218 -- <adjust statements 1>
7220 -- when <discrete choices N> =>
7221 -- <adjust statements N>
7225 Make_Case_Statement
(Loc
,
7227 Make_Selected_Component
(Loc
,
7228 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7230 Make_Identifier
(Loc
,
7231 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7232 Alternatives
=> Var_Alts
);
7236 -- Add the variant case statement to the list of statements
7238 if Present
(Var_Case
) then
7239 Append_To
(Stmts
, Var_Case
);
7242 -- If the component list did not have any controlled components
7243 -- nor variants, return null.
7245 if Is_Empty_List
(Stmts
) then
7246 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7250 end Process_Component_List_For_Adjust
;
7254 Bod_Stmts
: List_Id
:= No_List
;
7255 Finalizer_Decls
: List_Id
:= No_List
;
7258 -- Start of processing for Build_Adjust_Statements
7261 Finalizer_Decls
:= New_List
;
7262 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7264 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7265 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7270 -- Create an adjust sequence for all record components
7272 if Present
(Component_List
(Rec_Def
)) then
7274 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7277 -- A derived record type must adjust all inherited components. This
7278 -- action poses the following problem:
7280 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7285 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7287 -- Deep_Adjust (Obj._parent);
7292 -- Adjusting the derived type will invoke Adjust of the parent and
7293 -- then that of the derived type. This is undesirable because both
7294 -- routines may modify shared components. Only the Adjust of the
7295 -- derived type should be invoked.
7297 -- To prevent this double adjustment of shared components,
7298 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7300 -- procedure Deep_Adjust
7301 -- (Obj : in out Some_Type;
7302 -- Flag : Boolean := True)
7310 -- When Deep_Adjust is invoked for field _parent, a value of False is
7311 -- provided for the flag:
7313 -- Deep_Adjust (Obj._parent, False);
7315 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7317 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7322 if Needs_Finalization
(Par_Typ
) then
7326 Make_Selected_Component
(Loc
,
7327 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7329 Make_Identifier
(Loc
, Name_uParent
)),
7335 -- Deep_Adjust (V._parent, False);
7338 -- when Id : others =>
7339 -- if not Raised then
7341 -- Save_Occurrence (E,
7342 -- Get_Current_Excep.all.all);
7346 if Present
(Call
) then
7349 if Exceptions_OK
then
7351 Make_Block_Statement
(Loc
,
7352 Handled_Statement_Sequence
=>
7353 Make_Handled_Sequence_Of_Statements
(Loc
,
7354 Statements
=> New_List
(Adj_Stmt
),
7355 Exception_Handlers
=> New_List
(
7356 Build_Exception_Handler
(Finalizer_Data
))));
7359 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7365 -- Adjust the object. This action must be performed last after all
7366 -- components have been adjusted.
7368 if Is_Controlled
(Typ
) then
7374 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7383 -- if not Raised then
7385 -- Save_Occurrence (E,
7386 -- Get_Current_Excep.all.all);
7391 if Present
(Proc
) then
7393 Make_Procedure_Call_Statement
(Loc
,
7394 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7395 Parameter_Associations
=> New_List
(
7396 Make_Identifier
(Loc
, Name_V
)));
7398 if Exceptions_OK
then
7400 Make_Block_Statement
(Loc
,
7401 Handled_Statement_Sequence
=>
7402 Make_Handled_Sequence_Of_Statements
(Loc
,
7403 Statements
=> New_List
(Adj_Stmt
),
7404 Exception_Handlers
=> New_List
(
7405 Build_Exception_Handler
7406 (Finalizer_Data
))));
7409 Append_To
(Bod_Stmts
,
7410 Make_If_Statement
(Loc
,
7411 Condition
=> Make_Identifier
(Loc
, Name_F
),
7412 Then_Statements
=> New_List
(Adj_Stmt
)));
7417 -- At this point either all adjustment statements have been generated
7418 -- or the type is not controlled.
7420 if Is_Empty_List
(Bod_Stmts
) then
7421 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7427 -- Abort : constant Boolean := Triggered_By_Abort;
7429 -- Abort : constant Boolean := False; -- no abort
7431 -- E : Exception_Occurrence;
7432 -- Raised : Boolean := False;
7435 -- <adjust statements>
7437 -- if Raised and then not Abort then
7438 -- Raise_From_Controlled_Operation (E);
7443 if Exceptions_OK
then
7444 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7449 Make_Block_Statement
(Loc
,
7452 Handled_Statement_Sequence
=>
7453 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7455 end Build_Adjust_Statements
;
7457 -------------------------------
7458 -- Build_Finalize_Statements --
7459 -------------------------------
7461 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7462 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7463 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7466 Finalizer_Data
: Finalization_Exception_Data
;
7467 Last_POC_Call
: Node_Id
:= Empty
;
7469 function Process_Component_List_For_Finalize
7471 In_Variant_Part
: Boolean := False) return List_Id
;
7472 -- Build all necessary finalization statements for a single component
7473 -- list. The statements may include a jump circuitry if flag Is_Local
7474 -- is enabled. In_Variant_Part indicates whether this is a recursive
7477 -----------------------------------------
7478 -- Process_Component_List_For_Finalize --
7479 -----------------------------------------
7481 function Process_Component_List_For_Finalize
7483 In_Variant_Part
: Boolean := False) return List_Id
7485 procedure Process_Component_For_Finalize
7490 Num_Comps
: in out Nat
);
7491 -- Process the declaration of a single controlled component. If
7492 -- flag Is_Local is enabled, create the corresponding label and
7493 -- jump circuitry. Alts is the list of case alternatives, Decls
7494 -- is the top level declaration list where labels are declared
7495 -- and Stmts is the list of finalization actions. Num_Comps
7496 -- denotes the current number of components needing finalization.
7498 ------------------------------------
7499 -- Process_Component_For_Finalize --
7500 ------------------------------------
7502 procedure Process_Component_For_Finalize
7507 Num_Comps
: in out Nat
)
7509 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7510 Typ
: constant Entity_Id
:= Etype
(Id
);
7517 Label_Id
: Entity_Id
;
7524 Make_Identifier
(Loc
,
7525 Chars
=> New_External_Name
('L', Num_Comps
));
7526 Set_Entity
(Label_Id
,
7527 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7528 Label
:= Make_Label
(Loc
, Label_Id
);
7531 Make_Implicit_Label_Declaration
(Loc
,
7532 Defining_Identifier
=> Entity
(Label_Id
),
7533 Label_Construct
=> Label
));
7540 Make_Case_Statement_Alternative
(Loc
,
7541 Discrete_Choices
=> New_List
(
7542 Make_Integer_Literal
(Loc
, Num_Comps
)),
7544 Statements
=> New_List
(
7545 Make_Goto_Statement
(Loc
,
7547 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7552 Append_To
(Stmts
, Label
);
7554 -- Decrease the number of components to be processed.
7555 -- This action yields a new Label_Id in future calls.
7557 Num_Comps
:= Num_Comps
- 1;
7562 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7564 -- begin -- Exception handlers allowed
7565 -- [Deep_]Finalize (V.Id);
7568 -- if not Raised then
7570 -- Save_Occurrence (E,
7571 -- Get_Current_Excep.all.all);
7578 Make_Selected_Component
(Loc
,
7579 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7580 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7583 -- Guard against a missing [Deep_]Finalize when the component
7584 -- type was not properly frozen.
7586 if Present
(Fin_Call
) then
7587 if Exceptions_OK
then
7589 Make_Block_Statement
(Loc
,
7590 Handled_Statement_Sequence
=>
7591 Make_Handled_Sequence_Of_Statements
(Loc
,
7592 Statements
=> New_List
(Fin_Call
),
7593 Exception_Handlers
=> New_List
(
7594 Build_Exception_Handler
(Finalizer_Data
))));
7597 Append_To
(Stmts
, Fin_Call
);
7599 end Process_Component_For_Finalize
;
7604 Counter_Id
: Entity_Id
:= Empty
;
7606 Decl_Id
: Entity_Id
;
7607 Decl_Typ
: Entity_Id
;
7610 Jump_Block
: Node_Id
;
7612 Label_Id
: Entity_Id
;
7617 -- Start of processing for Process_Component_List_For_Finalize
7620 -- Perform an initial check, look for controlled and per-object
7621 -- constrained components.
7623 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7625 -- Create a state counter to service the current component list.
7626 -- This step is performed before the variants are inspected in
7627 -- order to generate the same state counter names as those from
7628 -- Build_Initialize_Statements.
7630 if Num_Comps
> 0 and then Is_Local
then
7631 Counter
:= Counter
+ 1;
7634 Make_Defining_Identifier
(Loc
,
7635 Chars
=> New_External_Name
('C', Counter
));
7638 -- Process the component in the following order:
7640 -- 2) Per-object constrained components
7641 -- 3) Regular components
7643 -- Start with the variant parts
7646 if Present
(Variant_Part
(Comps
)) then
7648 Var_Alts
: constant List_Id
:= New_List
;
7652 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7653 while Present
(Var
) loop
7656 -- when <discrete choices> =>
7657 -- <finalize statements>
7659 Append_To
(Var_Alts
,
7660 Make_Case_Statement_Alternative
(Loc
,
7662 New_Copy_List
(Discrete_Choices
(Var
)),
7664 Process_Component_List_For_Finalize
(
7665 Component_List
(Var
),
7666 In_Variant_Part
=> True)));
7668 Next_Non_Pragma
(Var
);
7672 -- case V.<discriminant> is
7673 -- when <discrete choices 1> =>
7674 -- <finalize statements 1>
7676 -- when <discrete choices N> =>
7677 -- <finalize statements N>
7681 Make_Case_Statement
(Loc
,
7683 Make_Selected_Component
(Loc
,
7684 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7686 Make_Identifier
(Loc
,
7687 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7688 Alternatives
=> Var_Alts
);
7692 -- The current component list does not have a single controlled
7693 -- component, however it may contain variants. Return the case
7694 -- statement for the variants or nothing.
7696 if Num_Comps
= 0 then
7697 if Present
(Var_Case
) then
7698 return New_List
(Var_Case
);
7700 return New_List
(Make_Null_Statement
(Loc
));
7704 -- Prepare all lists
7710 -- Process all per-object constrained components in reverse order
7713 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7714 while Present
(Decl
) loop
7715 Decl_Id
:= Defining_Identifier
(Decl
);
7716 Decl_Typ
:= Etype
(Decl_Id
);
7720 if Chars
(Decl_Id
) /= Name_uParent
7721 and then Needs_Finalization
(Decl_Typ
)
7722 and then Has_Access_Constraint
(Decl_Id
)
7723 and then No
(Expression
(Decl
))
7725 Process_Component_For_Finalize
7726 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7729 Prev_Non_Pragma
(Decl
);
7733 if not In_Variant_Part
then
7734 Last_POC_Call
:= Last
(Stmts
);
7735 -- In the case of a type extension, the deep-finalize call
7736 -- for the _Parent component will be inserted here.
7739 -- Process the rest of the components in reverse order
7741 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7742 while Present
(Decl
) loop
7743 Decl_Id
:= Defining_Identifier
(Decl
);
7744 Decl_Typ
:= Etype
(Decl_Id
);
7748 if Chars
(Decl_Id
) /= Name_uParent
7749 and then Needs_Finalization
(Decl_Typ
)
7751 -- Skip per-object constrained components since they were
7752 -- handled in the above step.
7754 if Has_Access_Constraint
(Decl_Id
)
7755 and then No
(Expression
(Decl
))
7759 Process_Component_For_Finalize
7760 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7764 Prev_Non_Pragma
(Decl
);
7769 -- LN : label; -- If Is_Local is enabled
7774 -- case CounterX is .
7784 -- <<LN>> -- If Is_Local is enabled
7786 -- [Deep_]Finalize (V.CompY);
7788 -- when Id : others =>
7789 -- if not Raised then
7791 -- Save_Occurrence (E,
7792 -- Get_Current_Excep.all.all);
7796 -- <<L0>> -- If Is_Local is enabled
7801 -- Add the declaration of default jump location L0, its
7802 -- corresponding alternative and its place in the statements.
7804 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7805 Set_Entity
(Label_Id
,
7806 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7807 Label
:= Make_Label
(Loc
, Label_Id
);
7809 Append_To
(Decls
, -- declaration
7810 Make_Implicit_Label_Declaration
(Loc
,
7811 Defining_Identifier
=> Entity
(Label_Id
),
7812 Label_Construct
=> Label
));
7814 Append_To
(Alts
, -- alternative
7815 Make_Case_Statement_Alternative
(Loc
,
7816 Discrete_Choices
=> New_List
(
7817 Make_Others_Choice
(Loc
)),
7819 Statements
=> New_List
(
7820 Make_Goto_Statement
(Loc
,
7821 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7823 Append_To
(Stmts
, Label
); -- statement
7825 -- Create the jump block
7828 Make_Case_Statement
(Loc
,
7829 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7830 Alternatives
=> Alts
));
7834 Make_Block_Statement
(Loc
,
7835 Declarations
=> Decls
,
7836 Handled_Statement_Sequence
=>
7837 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7839 if Present
(Var_Case
) then
7840 return New_List
(Var_Case
, Jump_Block
);
7842 return New_List
(Jump_Block
);
7844 end Process_Component_List_For_Finalize
;
7848 Bod_Stmts
: List_Id
:= No_List
;
7849 Finalizer_Decls
: List_Id
:= No_List
;
7852 -- Start of processing for Build_Finalize_Statements
7855 Finalizer_Decls
:= New_List
;
7856 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7858 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7859 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7864 -- Create a finalization sequence for all record components
7866 if Present
(Component_List
(Rec_Def
)) then
7868 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7871 -- A derived record type must finalize all inherited components. This
7872 -- action poses the following problem:
7874 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7879 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7881 -- Deep_Finalize (Obj._parent);
7886 -- Finalizing the derived type will invoke Finalize of the parent and
7887 -- then that of the derived type. This is undesirable because both
7888 -- routines may modify shared components. Only the Finalize of the
7889 -- derived type should be invoked.
7891 -- To prevent this double adjustment of shared components,
7892 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7894 -- procedure Deep_Finalize
7895 -- (Obj : in out Some_Type;
7896 -- Flag : Boolean := True)
7904 -- When Deep_Finalize is invoked for field _parent, a value of False
7905 -- is provided for the flag:
7907 -- Deep_Finalize (Obj._parent, False);
7909 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7911 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7916 if Needs_Finalization
(Par_Typ
) then
7920 Make_Selected_Component
(Loc
,
7921 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7923 Make_Identifier
(Loc
, Name_uParent
)),
7929 -- Deep_Finalize (V._parent, False);
7932 -- when Id : others =>
7933 -- if not Raised then
7935 -- Save_Occurrence (E,
7936 -- Get_Current_Excep.all.all);
7940 if Present
(Call
) then
7943 if Exceptions_OK
then
7945 Make_Block_Statement
(Loc
,
7946 Handled_Statement_Sequence
=>
7947 Make_Handled_Sequence_Of_Statements
(Loc
,
7948 Statements
=> New_List
(Fin_Stmt
),
7949 Exception_Handlers
=> New_List
(
7950 Build_Exception_Handler
7951 (Finalizer_Data
))));
7954 -- The intended component finalization order is
7955 -- 1) POC components of extension
7956 -- 2) _Parent component
7957 -- 3) non-POC components of extension.
7959 -- With this "finalize the parent part in the middle"
7960 -- ordering, we can avoid the need for making two
7961 -- calls to the parent's subprogram in the way that
7962 -- is necessary for Init_Procs. This does have the
7963 -- peculiar (but legal) consequence that the parent's
7964 -- non-POC components are finalized before the
7965 -- non-POC extension components. This violates the
7966 -- usual "finalize in reverse declaration order"
7967 -- principle, but that's ok (see Ada RM 7.6.1(9)).
7969 -- Last_POC_Call should be non-empty if the extension
7970 -- has at least one POC. Interactions with variant
7971 -- parts are incorrectly ignored.
7973 if Present
(Last_POC_Call
) then
7974 Insert_After
(Last_POC_Call
, Fin_Stmt
);
7976 -- At this point, we could look for the common case
7977 -- where there are no POC components anywhere in
7978 -- sight (inherited or not) and, in that common case,
7979 -- call Append_To instead of Prepend_To. That would
7980 -- result in finalizing the parent part after, rather
7981 -- than before, the extension components. That might
7982 -- be more intuitive (as discussed in preceding
7983 -- comment), but it is not required.
7984 Prepend_To
(Bod_Stmts
, Fin_Stmt
);
7991 -- Finalize the object. This action must be performed first before
7992 -- all components have been finalized.
7994 if Is_Controlled
(Typ
) and then not Is_Local
then
8000 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8009 -- if not Raised then
8011 -- Save_Occurrence (E,
8012 -- Get_Current_Excep.all.all);
8017 if Present
(Proc
) then
8019 Make_Procedure_Call_Statement
(Loc
,
8020 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8021 Parameter_Associations
=> New_List
(
8022 Make_Identifier
(Loc
, Name_V
)));
8024 if Exceptions_OK
then
8026 Make_Block_Statement
(Loc
,
8027 Handled_Statement_Sequence
=>
8028 Make_Handled_Sequence_Of_Statements
(Loc
,
8029 Statements
=> New_List
(Fin_Stmt
),
8030 Exception_Handlers
=> New_List
(
8031 Build_Exception_Handler
8032 (Finalizer_Data
))));
8035 Prepend_To
(Bod_Stmts
,
8036 Make_If_Statement
(Loc
,
8037 Condition
=> Make_Identifier
(Loc
, Name_F
),
8038 Then_Statements
=> New_List
(Fin_Stmt
)));
8043 -- At this point either all finalization statements have been
8044 -- generated or the type is not controlled.
8046 if No
(Bod_Stmts
) then
8047 return New_List
(Make_Null_Statement
(Loc
));
8051 -- Abort : constant Boolean := Triggered_By_Abort;
8053 -- Abort : constant Boolean := False; -- no abort
8055 -- E : Exception_Occurrence;
8056 -- Raised : Boolean := False;
8059 -- <finalize statements>
8061 -- if Raised and then not Abort then
8062 -- Raise_From_Controlled_Operation (E);
8067 if Exceptions_OK
then
8068 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8073 Make_Block_Statement
(Loc
,
8076 Handled_Statement_Sequence
=>
8077 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8079 end Build_Finalize_Statements
;
8081 -----------------------
8082 -- Parent_Field_Type --
8083 -----------------------
8085 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8089 Field
:= First_Entity
(Typ
);
8090 while Present
(Field
) loop
8091 if Chars
(Field
) = Name_uParent
then
8092 return Etype
(Field
);
8095 Next_Entity
(Field
);
8098 -- A derived tagged type should always have a parent field
8100 raise Program_Error
;
8101 end Parent_Field_Type
;
8103 ---------------------------
8104 -- Preprocess_Components --
8105 ---------------------------
8107 procedure Preprocess_Components
8109 Num_Comps
: out Nat
;
8110 Has_POC
: out Boolean)
8120 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8121 while Present
(Decl
) loop
8122 Id
:= Defining_Identifier
(Decl
);
8125 -- Skip field _parent
8127 if Chars
(Id
) /= Name_uParent
8128 and then Needs_Finalization
(Typ
)
8130 Num_Comps
:= Num_Comps
+ 1;
8132 if Has_Access_Constraint
(Id
)
8133 and then No
(Expression
(Decl
))
8139 Next_Non_Pragma
(Decl
);
8141 end Preprocess_Components
;
8143 -- Start of processing for Make_Deep_Record_Body
8147 when Address_Case
=>
8148 return Make_Finalize_Address_Stmts
(Typ
);
8151 return Build_Adjust_Statements
(Typ
);
8153 when Finalize_Case
=>
8154 return Build_Finalize_Statements
(Typ
);
8156 when Initialize_Case
=>
8158 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8161 if Is_Controlled
(Typ
) then
8163 Make_Procedure_Call_Statement
(Loc
,
8166 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8167 Parameter_Associations
=> New_List
(
8168 Make_Identifier
(Loc
, Name_V
))));
8174 end Make_Deep_Record_Body
;
8176 ----------------------
8177 -- Make_Final_Call --
8178 ----------------------
8180 function Make_Final_Call
8183 Skip_Self
: Boolean := False) return Node_Id
8185 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8187 Prot_Typ
: Entity_Id
:= Empty
;
8188 Fin_Id
: Entity_Id
:= Empty
;
8195 -- Recover the proper type which contains [Deep_]Finalize
8197 if Is_Class_Wide_Type
(Typ
) then
8198 Utyp
:= Root_Type
(Typ
);
8201 elsif Is_Concurrent_Type
(Typ
) then
8202 Utyp
:= Corresponding_Record_Type
(Typ
);
8204 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8206 elsif Is_Private_Type
(Typ
)
8207 and then Present
(Underlying_Type
(Typ
))
8208 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8210 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8212 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8219 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8220 Set_Assignment_OK
(Ref
);
8222 -- Deal with untagged derivation of private views. If the parent type
8223 -- is a protected type, Deep_Finalize is found on the corresponding
8224 -- record of the ancestor.
8226 if Is_Untagged_Derivation
(Typ
) then
8227 if Is_Protected_Type
(Typ
) then
8228 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8230 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8232 if Is_Protected_Type
(Utyp
) then
8233 Utyp
:= Corresponding_Record_Type
(Utyp
);
8237 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8238 Set_Assignment_OK
(Ref
);
8241 -- Deal with derived private types which do not inherit primitives from
8242 -- their parents. In this case, [Deep_]Finalize can be found in the full
8243 -- view of the parent type.
8246 and then Is_Tagged_Type
(Utyp
)
8247 and then Is_Derived_Type
(Utyp
)
8248 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8249 and then Is_Private_Type
(Etype
(Utyp
))
8250 and then Present
(Full_View
(Etype
(Utyp
)))
8252 Utyp
:= Full_View
(Etype
(Utyp
));
8253 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8254 Set_Assignment_OK
(Ref
);
8257 -- When dealing with the completion of a private type, use the base type
8260 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8261 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8263 Utyp
:= Base_Type
(Utyp
);
8264 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8265 Set_Assignment_OK
(Ref
);
8268 -- Detect if Typ is a protected type or an expanded protected type and
8269 -- store the relevant type within Prot_Typ for later processing.
8271 if Is_Protected_Type
(Typ
) then
8274 elsif Ekind
(Typ
) = E_Record_Type
8275 and then Present
(Corresponding_Concurrent_Type
(Typ
))
8276 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Typ
))
8278 Prot_Typ
:= Corresponding_Concurrent_Type
(Typ
);
8281 -- The underlying type may not be present due to a missing full view. In
8282 -- this case freezing did not take place and there is no [Deep_]Finalize
8283 -- primitive to call.
8288 elsif Skip_Self
then
8289 if Has_Controlled_Component
(Utyp
) then
8290 if Is_Tagged_Type
(Utyp
) then
8291 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8293 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8297 -- Class-wide types, interfaces and types with controlled components
8299 elsif Is_Class_Wide_Type
(Typ
)
8300 or else Is_Interface
(Typ
)
8301 or else Has_Controlled_Component
(Utyp
)
8303 if Is_Tagged_Type
(Utyp
) then
8304 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8306 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8309 -- Derivations from [Limited_]Controlled
8311 elsif Is_Controlled
(Utyp
) then
8312 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8316 elsif Is_Tagged_Type
(Utyp
) then
8317 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8319 -- Protected types: these also require finalization even though they
8320 -- are not marked controlled explicitly.
8322 elsif Present
(Prot_Typ
) then
8323 -- Protected objects do not need to be finalized on restricted
8326 if Restricted_Profile
then
8329 -- ??? Only handle the simple case for now. Will not support a record
8330 -- or array containing protected objects.
8332 elsif Is_Simple_Protected_Type
(Prot_Typ
) then
8333 Fin_Id
:= RTE
(RE_Finalize_Protection
);
8335 raise Program_Error
;
8338 raise Program_Error
;
8341 if Present
(Fin_Id
) then
8343 -- When finalizing a class-wide object, do not convert to the root
8344 -- type in order to produce a dispatching call.
8346 if Is_Class_Wide_Type
(Typ
) then
8349 -- Ensure that a finalization routine is at least decorated in order
8350 -- to inspect the object parameter.
8352 elsif Analyzed
(Fin_Id
)
8353 or else Ekind
(Fin_Id
) = E_Procedure
8355 -- In certain cases, such as the creation of Stream_Read, the
8356 -- visible entity of the type is its full view. Since Stream_Read
8357 -- will have to create an object of type Typ, the local object
8358 -- will be finalzed by the scope finalizer generated later on. The
8359 -- object parameter of Deep_Finalize will always use the private
8360 -- view of the type. To avoid such a clash between a private and a
8361 -- full view, perform an unchecked conversion of the object
8362 -- reference to the private view.
8365 Formal_Typ
: constant Entity_Id
:=
8366 Etype
(First_Formal
(Fin_Id
));
8368 if Is_Private_Type
(Formal_Typ
)
8369 and then Present
(Full_View
(Formal_Typ
))
8370 and then Full_View
(Formal_Typ
) = Utyp
8372 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8376 -- If the object is unanalyzed, set its expected type for use in
8377 -- Convert_View in case an additional conversion is needed.
8380 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
8382 Set_Etype
(Ref
, Typ
);
8385 Ref
:= Convert_View
(Fin_Id
, Ref
);
8392 Skip_Self
=> Skip_Self
);
8394 pragma Assert
(Serious_Errors_Detected
> 0
8395 or else not Has_Controlled_Component
(Utyp
));
8398 end Make_Final_Call
;
8400 --------------------------------
8401 -- Make_Finalize_Address_Body --
8402 --------------------------------
8404 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8405 Is_Task
: constant Boolean :=
8406 Ekind
(Typ
) = E_Record_Type
8407 and then Is_Concurrent_Record_Type
(Typ
)
8408 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8410 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8411 Proc_Id
: Entity_Id
;
8415 -- The corresponding records of task types are not controlled by design.
8416 -- For the sake of completeness, create an empty Finalize_Address to be
8417 -- used in task class-wide allocations.
8422 -- Nothing to do if the type is not controlled or it already has a
8423 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8424 -- come from source. These are usually generated for completeness and
8425 -- do not need the Finalize_Address primitive.
8427 elsif not Needs_Finalization
(Typ
)
8428 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8430 (Is_Class_Wide_Type
(Typ
)
8431 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8432 and then not Comes_From_Source
(Root_Type
(Typ
)))
8437 -- Do not generate Finalize_Address routine for CodePeer
8439 if CodePeer_Mode
then
8444 Make_Defining_Identifier
(Loc
,
8445 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8449 -- procedure <Typ>FD (V : System.Address) is
8451 -- null; -- for tasks
8453 -- declare -- for all other types
8454 -- type Pnn is access all Typ;
8455 -- for Pnn'Storage_Size use 0;
8457 -- [Deep_]Finalize (Pnn (V).all);
8462 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8464 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8468 Make_Subprogram_Body
(Loc
,
8470 Make_Procedure_Specification
(Loc
,
8471 Defining_Unit_Name
=> Proc_Id
,
8473 Parameter_Specifications
=> New_List
(
8474 Make_Parameter_Specification
(Loc
,
8475 Defining_Identifier
=>
8476 Make_Defining_Identifier
(Loc
, Name_V
),
8478 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8480 Declarations
=> No_List
,
8482 Handled_Statement_Sequence
=>
8483 Make_Handled_Sequence_Of_Statements
(Loc
,
8484 Statements
=> Stmts
)));
8486 Set_TSS
(Typ
, Proc_Id
);
8487 end Make_Finalize_Address_Body
;
8489 ---------------------------------
8490 -- Make_Finalize_Address_Stmts --
8491 ---------------------------------
8493 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8494 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8497 Desig_Typ
: Entity_Id
;
8498 Fin_Block
: Node_Id
;
8501 Ptr_Typ
: Entity_Id
;
8504 if Is_Array_Type
(Typ
) then
8505 if Is_Constrained
(First_Subtype
(Typ
)) then
8506 Desig_Typ
:= First_Subtype
(Typ
);
8508 Desig_Typ
:= Base_Type
(Typ
);
8511 -- Class-wide types of constrained root types
8513 elsif Is_Class_Wide_Type
(Typ
)
8514 and then Has_Discriminants
(Root_Type
(Typ
))
8516 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8519 Parent_Typ
: Entity_Id
;
8520 Parent_Utyp
: Entity_Id
;
8523 -- Climb the parent type chain looking for a non-constrained type
8525 Parent_Typ
:= Root_Type
(Typ
);
8526 while Parent_Typ
/= Etype
(Parent_Typ
)
8527 and then Has_Discriminants
(Parent_Typ
)
8529 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8531 Parent_Typ
:= Etype
(Parent_Typ
);
8534 -- Handle views created for tagged types with unknown
8537 if Is_Underlying_Record_View
(Parent_Typ
) then
8538 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8541 Parent_Utyp
:= Underlying_Type
(Parent_Typ
);
8543 -- Handle views created for a synchronized private extension with
8544 -- known, non-defaulted discriminants. In that case, parent_typ
8545 -- will be the private extension, as it is the first "non
8546 -- -constrained" type in the parent chain. Unfortunately, the
8547 -- underlying type, being a protected or task type, is not the
8548 -- "real" type needing finalization. Rather, the "corresponding
8549 -- record type" should be the designated type here. In fact, TSS
8550 -- finalizer generation is specifically skipped for the nominal
8551 -- class-wide type of (the full view of) a concurrent type (see
8552 -- exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate
8553 -- the underlying record (Tprot_typeVC), we will end up trying to
8554 -- dispatch to prot_typeVDF from an incorrectly designated
8555 -- Tprot_typeC, which is, of course, not actually a member of
8556 -- prot_typeV'Class, and thus incompatible.
8558 if Ekind
(Parent_Utyp
) in Concurrent_Kind
8559 and then Present
(Corresponding_Record_Type
(Parent_Utyp
))
8561 Parent_Utyp
:= Corresponding_Record_Type
(Parent_Utyp
);
8564 Desig_Typ
:= Class_Wide_Type
(Parent_Utyp
);
8574 -- type Ptr_Typ is access all Typ;
8575 -- for Ptr_Typ'Storage_Size use 0;
8577 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8580 Make_Full_Type_Declaration
(Loc
,
8581 Defining_Identifier
=> Ptr_Typ
,
8583 Make_Access_To_Object_Definition
(Loc
,
8584 All_Present
=> True,
8585 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8587 Make_Attribute_Definition_Clause
(Loc
,
8588 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8589 Chars
=> Name_Storage_Size
,
8590 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8592 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8594 -- Unconstrained arrays require special processing in order to retrieve
8595 -- the elements. To achieve this, we have to skip the dope vector which
8596 -- lays in front of the elements and then use a thin pointer to perform
8597 -- the address-to-access conversion.
8599 if Is_Array_Type
(Typ
)
8600 and then not Is_Constrained
(First_Subtype
(Typ
))
8603 Dope_Id
: Entity_Id
;
8606 -- Ensure that Ptr_Typ is a thin pointer; generate:
8607 -- for Ptr_Typ'Size use System.Address'Size;
8610 Make_Attribute_Definition_Clause
(Loc
,
8611 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8614 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8617 -- Dnn : constant Storage_Offset :=
8618 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8620 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8623 Make_Object_Declaration
(Loc
,
8624 Defining_Identifier
=> Dope_Id
,
8625 Constant_Present
=> True,
8626 Object_Definition
=>
8627 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8629 Make_Op_Divide
(Loc
,
8631 Make_Attribute_Reference
(Loc
,
8632 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8633 Attribute_Name
=> Name_Descriptor_Size
),
8635 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8637 -- Shift the address from the start of the dope vector to the
8638 -- start of the elements:
8642 -- Note that this is done through a wrapper routine since RTSfind
8643 -- cannot retrieve operations with string names of the form "+".
8646 Make_Function_Call
(Loc
,
8648 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8649 Parameter_Associations
=> New_List
(
8651 New_Occurrence_Of
(Dope_Id
, Loc
)));
8658 Make_Explicit_Dereference
(Loc
,
8659 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8662 if Present
(Fin_Call
) then
8664 Make_Block_Statement
(Loc
,
8665 Declarations
=> Decls
,
8666 Handled_Statement_Sequence
=>
8667 Make_Handled_Sequence_Of_Statements
(Loc
,
8668 Statements
=> New_List
(Fin_Call
)));
8670 -- Otherwise previous errors or a missing full view may prevent the
8671 -- proper freezing of the designated type. If this is the case, there
8672 -- is no [Deep_]Finalize primitive to call.
8675 Fin_Block
:= Make_Null_Statement
(Loc
);
8678 return New_List
(Fin_Block
);
8679 end Make_Finalize_Address_Stmts
;
8681 -------------------------------------
8682 -- Make_Handler_For_Ctrl_Operation --
8683 -------------------------------------
8687 -- when E : others =>
8688 -- Raise_From_Controlled_Operation (E);
8693 -- raise Program_Error [finalize raised exception];
8695 -- depending on whether Raise_From_Controlled_Operation is available
8697 function Make_Handler_For_Ctrl_Operation
8698 (Loc
: Source_Ptr
) return Node_Id
8701 -- Choice parameter (for the first case above)
8703 Raise_Node
: Node_Id
;
8704 -- Procedure call or raise statement
8707 -- Standard run-time: add choice parameter E and pass it to
8708 -- Raise_From_Controlled_Operation so that the original exception
8709 -- name and message can be recorded in the exception message for
8712 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8713 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8715 Make_Procedure_Call_Statement
(Loc
,
8718 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8719 Parameter_Associations
=> New_List
(
8720 New_Occurrence_Of
(E_Occ
, Loc
)));
8722 -- Restricted run-time: exception messages are not supported
8727 Make_Raise_Program_Error
(Loc
,
8728 Reason
=> PE_Finalize_Raised_Exception
);
8732 Make_Implicit_Exception_Handler
(Loc
,
8733 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8734 Choice_Parameter
=> E_Occ
,
8735 Statements
=> New_List
(Raise_Node
));
8736 end Make_Handler_For_Ctrl_Operation
;
8738 --------------------
8739 -- Make_Init_Call --
8740 --------------------
8742 function Make_Init_Call
8744 Typ
: Entity_Id
) return Node_Id
8746 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8755 -- Deal with the type and object reference. Depending on the context, an
8756 -- object reference may need several conversions.
8758 if Is_Concurrent_Type
(Typ
) then
8760 Utyp
:= Corresponding_Record_Type
(Typ
);
8761 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8763 elsif Is_Private_Type
(Typ
)
8764 and then Present
(Full_View
(Typ
))
8765 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8768 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8769 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8776 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8777 Set_Assignment_OK
(Ref
);
8779 -- Deal with untagged derivation of private views
8781 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8782 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8783 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8785 -- The following is to prevent problems with UC see 1.156 RH ???
8787 Set_Assignment_OK
(Ref
);
8790 -- If the underlying_type is a subtype, then we are dealing with the
8791 -- completion of a private type. We need to access the base type and
8792 -- generate a conversion to it.
8794 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8795 pragma Assert
(Is_Private_Type
(Typ
));
8796 Utyp
:= Base_Type
(Utyp
);
8797 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8800 -- The underlying type may not be present due to a missing full view.
8801 -- In this case freezing did not take place and there is no suitable
8802 -- [Deep_]Initialize primitive to call.
8803 -- If Typ is protected then no additional processing is needed either.
8806 or else Is_Protected_Type
(Typ
)
8811 -- Select the appropriate version of initialize
8813 if Has_Controlled_Component
(Utyp
) then
8814 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8816 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8817 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8820 -- If initialization procedure for an array of controlled objects is
8821 -- trivial, do not generate a useless call to it.
8822 -- The initialization procedure may be missing altogether in the case
8823 -- of a derived container whose components have trivial initialization.
8826 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8828 (not Comes_From_Source
(Proc
)
8829 and then Present
(Alias
(Proc
))
8830 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8835 -- The object reference may need another conversion depending on the
8836 -- type of the formal and that of the actual.
8838 Ref
:= Convert_View
(Proc
, Ref
);
8841 -- [Deep_]Initialize (Ref);
8844 Make_Procedure_Call_Statement
(Loc
,
8845 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8846 Parameter_Associations
=> New_List
(Ref
));
8849 ------------------------------
8850 -- Make_Local_Deep_Finalize --
8851 ------------------------------
8853 function Make_Local_Deep_Finalize
8855 Nam
: Entity_Id
) return Node_Id
8857 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8861 Formals
:= New_List
(
8865 Make_Parameter_Specification
(Loc
,
8866 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8868 Out_Present
=> True,
8869 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8871 -- F : Boolean := True
8873 Make_Parameter_Specification
(Loc
,
8874 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8875 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8876 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8878 -- Add the necessary number of counters to represent the initialization
8879 -- state of an object.
8882 Make_Subprogram_Body
(Loc
,
8884 Make_Procedure_Specification
(Loc
,
8885 Defining_Unit_Name
=> Nam
,
8886 Parameter_Specifications
=> Formals
),
8888 Declarations
=> No_List
,
8890 Handled_Statement_Sequence
=>
8891 Make_Handled_Sequence_Of_Statements
(Loc
,
8892 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8893 end Make_Local_Deep_Finalize
;
8895 ------------------------------------
8896 -- Make_Set_Finalize_Address_Call --
8897 ------------------------------------
8899 function Make_Set_Finalize_Address_Call
8901 Ptr_Typ
: Entity_Id
) return Node_Id
8903 -- It is possible for Ptr_Typ to be a partial view, if the access type
8904 -- is a full view declared in the private part of a nested package, and
8905 -- the finalization actions take place when completing analysis of the
8906 -- enclosing unit. For this reason use Underlying_Type twice below.
8908 Desig_Typ
: constant Entity_Id
:=
8910 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8911 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8912 Fin_Mas
: constant Entity_Id
:=
8913 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8916 -- Both the finalization master and primitive Finalize_Address must be
8919 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8922 -- Set_Finalize_Address
8923 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8926 Make_Procedure_Call_Statement
(Loc
,
8928 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8929 Parameter_Associations
=> New_List
(
8930 New_Occurrence_Of
(Fin_Mas
, Loc
),
8932 Make_Attribute_Reference
(Loc
,
8933 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8934 Attribute_Name
=> Name_Unrestricted_Access
)));
8935 end Make_Set_Finalize_Address_Call
;
8937 --------------------------
8938 -- Make_Transient_Block --
8939 --------------------------
8941 function Make_Transient_Block
8944 Par
: Node_Id
) return Node_Id
8946 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8947 -- Determine whether scoping entity Id manages the secondary stack
8949 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
8950 -- Return True when N appears within a loop and no block is containing N
8952 -----------------------
8953 -- Manages_Sec_Stack --
8954 -----------------------
8956 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8960 -- An exception handler with a choice parameter utilizes a dummy
8961 -- block to provide a declarative region. Such a block should not
8962 -- be considered because it never manifests in the tree and can
8963 -- never release the secondary stack.
8967 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8974 return Uses_Sec_Stack
(Id
);
8979 end Manages_Sec_Stack
;
8981 ---------------------------
8982 -- Within_Loop_Statement --
8983 ---------------------------
8985 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
8986 Par
: Node_Id
:= Parent
(N
);
8989 while Nkind
(Par
) not in
8990 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
8991 N_Package_Specification | N_Proper_Body
8993 pragma Assert
(Present
(Par
));
8994 Par
:= Parent
(Par
);
8997 return Nkind
(Par
) = N_Loop_Statement
;
8998 end Within_Loop_Statement
;
9002 Decls
: constant List_Id
:= New_List
;
9003 Instrs
: constant List_Id
:= New_List
(Action
);
9004 Trans_Id
: constant Entity_Id
:= Current_Scope
;
9010 -- Start of processing for Make_Transient_Block
9013 -- Even though the transient block is tasked with managing the secondary
9014 -- stack, the block may forgo this functionality depending on how the
9015 -- secondary stack is managed by enclosing scopes.
9017 if Manages_Sec_Stack
(Trans_Id
) then
9019 -- Determine whether an enclosing scope already manages the secondary
9022 Scop
:= Scope
(Trans_Id
);
9023 while Present
(Scop
) loop
9025 -- It should not be possible to reach Standard without hitting one
9026 -- of the other cases first unless Standard was manually pushed.
9028 if Scop
= Standard_Standard
then
9031 -- The transient block is within a function which returns on the
9032 -- secondary stack. Take a conservative approach and assume that
9033 -- the value on the secondary stack is part of the result. Note
9034 -- that it is not possible to detect this dependency without flow
9035 -- analysis which the compiler does not have. Letting the object
9036 -- live longer than the transient block will not leak any memory
9037 -- because the caller will reclaim the total storage used by the
9040 elsif Ekind
(Scop
) = E_Function
9041 and then Sec_Stack_Needed_For_Return
(Scop
)
9043 Set_Uses_Sec_Stack
(Trans_Id
, False);
9046 -- The transient block must manage the secondary stack when the
9047 -- block appears within a loop in order to reclaim the memory at
9050 elsif Ekind
(Scop
) = E_Loop
then
9053 -- Ditto when the block appears without a block that does not
9054 -- manage the secondary stack and is located within a loop.
9056 elsif Ekind
(Scop
) = E_Block
9057 and then not Manages_Sec_Stack
(Scop
)
9058 and then Present
(Block_Node
(Scop
))
9059 and then Within_Loop_Statement
(Block_Node
(Scop
))
9063 -- The transient block does not need to manage the secondary stack
9064 -- when there is an enclosing construct which already does that.
9065 -- This optimization saves on SS_Mark and SS_Release calls but may
9066 -- allow objects to live a little longer than required.
9068 -- The transient block must manage the secondary stack when switch
9069 -- -gnatd.s (strict management) is in effect.
9071 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9072 Set_Uses_Sec_Stack
(Trans_Id
, False);
9075 -- Prevent the search from going too far because transient blocks
9076 -- are bounded by packages and subprogram scopes.
9078 elsif Ekind
(Scop
) in E_Entry
9088 Scop
:= Scope
(Scop
);
9092 -- Create the transient block. Set the parent now since the block itself
9093 -- is not part of the tree. The current scope is the E_Block entity that
9094 -- has been pushed by Establish_Transient_Scope.
9096 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9099 Make_Block_Statement
(Loc
,
9100 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9101 Declarations
=> Decls
,
9102 Handled_Statement_Sequence
=>
9103 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9104 Has_Created_Identifier
=> True);
9105 Set_Parent
(Block
, Par
);
9107 -- Insert actions stuck in the transient scopes as well as all freezing
9108 -- nodes needed by those actions. Do not insert cleanup actions here,
9109 -- they will be transferred to the newly created block.
9111 Insert_Actions_In_Scope_Around
9112 (Action
, Clean
=> False, Manage_SS
=> False);
9114 Insert
:= Prev
(Action
);
9116 if Present
(Insert
) then
9117 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9120 -- Transfer cleanup actions to the newly created block
9123 Cleanup_Actions
: List_Id
9124 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9125 Actions_To_Be_Wrapped
(Cleanup
);
9127 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9128 Cleanup_Actions
:= No_List
;
9131 -- When the transient scope was established, we pushed the entry for the
9132 -- transient scope onto the scope stack, so that the scope was active
9133 -- for the installation of finalizable entities etc. Now we must remove
9134 -- this entry, since we have constructed a proper block.
9139 end Make_Transient_Block
;
9141 ------------------------
9142 -- Node_To_Be_Wrapped --
9143 ------------------------
9145 function Node_To_Be_Wrapped
return Node_Id
is
9147 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9148 end Node_To_Be_Wrapped
;
9150 ----------------------------
9151 -- Store_Actions_In_Scope --
9152 ----------------------------
9154 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9155 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9156 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9159 if Is_Empty_List
(Actions
) then
9162 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9163 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9165 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9170 elsif AK
= Before
then
9171 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9174 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9176 end Store_Actions_In_Scope
;
9178 ----------------------------------
9179 -- Store_After_Actions_In_Scope --
9180 ----------------------------------
9182 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9184 Store_Actions_In_Scope
(After
, L
);
9185 end Store_After_Actions_In_Scope
;
9187 -----------------------------------
9188 -- Store_Before_Actions_In_Scope --
9189 -----------------------------------
9191 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9193 Store_Actions_In_Scope
(Before
, L
);
9194 end Store_Before_Actions_In_Scope
;
9196 -----------------------------------
9197 -- Store_Cleanup_Actions_In_Scope --
9198 -----------------------------------
9200 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9202 Store_Actions_In_Scope
(Cleanup
, L
);
9203 end Store_Cleanup_Actions_In_Scope
;
9209 procedure Unnest_Block
(Decl
: Node_Id
) is
9210 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9212 Local_Body
: Node_Id
;
9213 Local_Call
: Node_Id
;
9214 Local_Proc
: Entity_Id
;
9215 Local_Scop
: Entity_Id
;
9218 Local_Scop
:= Entity
(Identifier
(Decl
));
9219 Ent
:= First_Entity
(Local_Scop
);
9221 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9224 Make_Subprogram_Body
(Loc
,
9226 Make_Procedure_Specification
(Loc
,
9227 Defining_Unit_Name
=> Local_Proc
),
9228 Declarations
=> Declarations
(Decl
),
9229 Handled_Statement_Sequence
=>
9230 Handled_Statement_Sequence
(Decl
));
9232 -- Handlers in the block may contain nested subprograms that require
9235 Check_Unnesting_In_Handlers
(Local_Body
);
9237 Rewrite
(Decl
, Local_Body
);
9239 Set_Has_Nested_Subprogram
(Local_Proc
);
9242 Make_Procedure_Call_Statement
(Loc
,
9243 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9245 Insert_After
(Decl
, Local_Call
);
9246 Analyze
(Local_Call
);
9248 -- The new subprogram has the same scope as the original block
9250 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9252 -- And the entity list of the new procedure is that of the block
9254 Set_First_Entity
(Local_Proc
, Ent
);
9256 -- Reset the scopes of all the entities to the new procedure
9258 while Present
(Ent
) loop
9259 Set_Scope
(Ent
, Local_Proc
);
9264 -------------------------
9265 -- Unnest_If_Statement --
9266 -------------------------
9268 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
9270 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
9271 -- A list of statements (that may be a list associated with a then,
9272 -- elsif, or else part of an if-statement) is traversed at the top
9273 -- level to determine whether it contains a subprogram body, and if so,
9274 -- the statements will be replaced with a new procedure body containing
9275 -- the statements followed by a call to the procedure. The individual
9276 -- statements may also be blocks, loops, or other if statements that
9277 -- themselves may require contain nested subprograms needing unnesting.
9279 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
9280 Subp_Found
: Boolean := False;
9283 if Is_Empty_List
(Stmts
) then
9288 Stmt
: Node_Id
:= First
(Stmts
);
9290 while Present
(Stmt
) loop
9291 if Nkind
(Stmt
) = N_Subprogram_Body
then
9300 -- The statements themselves may be blocks, loops, etc. that in turn
9301 -- contain nested subprograms requiring an unnesting transformation.
9302 -- We perform this traversal after looking for subprogram bodies, to
9303 -- avoid considering procedures created for one of those statements
9304 -- (such as a block rewritten as a procedure) as a nested subprogram
9305 -- of the statement list (which could result in an unneeded wrapper
9308 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
9310 -- If there was a top-level subprogram body in the statement list,
9311 -- then perform an unnesting transformation on the list by replacing
9312 -- the statements with a wrapper procedure body containing the
9313 -- original statements followed by a call to that procedure.
9316 Unnest_Statement_List
(Stmts
);
9318 end Check_Stmts_For_Subp_Unnesting
;
9322 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
9323 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
9325 -- Start of processing for Unnest_If_Statement
9328 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
9329 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
9331 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
9333 Elsif_Part
: Node_Id
:=
9334 First
(Elsif_Parts
(If_Stmt
));
9335 Elsif_Stmts
: List_Id
;
9337 while Present
(Elsif_Part
) loop
9338 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
9340 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
9341 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
9348 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
9349 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
9350 end Unnest_If_Statement
;
9356 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
9358 procedure Fixup_Inner_Scopes
(Loop_Stmt
: Node_Id
);
9359 -- The loops created by the compiler for array aggregates can have
9360 -- nested finalization procedure when the type of the array components
9361 -- needs finalization. It has the following form:
9363 -- for J4b in 10 .. 12 loop
9365 -- procedure __finalizer;
9367 -- procedure __finalizer is
9371 -- obj (J4b) := ...;
9373 -- When the compiler creates the N_Block_Statement, it sets its scope to
9374 -- the upper scope (the one containing the loop).
9376 -- The Unnest_Loop procedure moves the N_Loop_Statement inside a new
9377 -- procedure and correctly sets the scopes for both the new procedure
9378 -- and the loop entity. The inner block scope is not modified and this
9379 -- leaves the Tree in an incoherent state (i.e. the inner procedure must
9380 -- have its enclosing procedure in its scope ancestries).
9382 -- This procedure fixes the scope links.
9384 -- Another (better) fix would be to have the block scope set to be the
9385 -- loop entity earlier (when the block is created or when the loop gets
9386 -- an actual entity set). But unfortunately this proved harder to
9389 procedure Fixup_Inner_Scopes
(Loop_Stmt
: Node_Id
) is
9390 Stmt
: Node_Id
:= First
(Statements
(Loop_Stmt
));
9391 Loop_Stmt_Ent
: constant Entity_Id
:= Entity
(Identifier
(Loop_Stmt
));
9392 Ent_To_Fix
: Entity_Id
;
9394 while Present
(Stmt
) loop
9395 if Nkind
(Stmt
) = N_Block_Statement
9396 and then Is_Abort_Block
(Stmt
)
9398 Ent_To_Fix
:= Entity
(Identifier
(Stmt
));
9399 Set_Scope
(Ent_To_Fix
, Loop_Stmt_Ent
);
9400 elsif Nkind
(Stmt
) = N_Loop_Statement
then
9401 Fixup_Inner_Scopes
(Stmt
);
9405 end Fixup_Inner_Scopes
;
9407 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
9409 Local_Body
: Node_Id
;
9410 Local_Call
: Node_Id
;
9411 Loop_Ent
: Entity_Id
;
9412 Local_Proc
: Entity_Id
;
9413 Loop_Copy
: constant Node_Id
:=
9414 Relocate_Node
(Loop_Stmt
);
9416 Loop_Ent
:= Entity
(Identifier
(Loop_Stmt
));
9417 Ent
:= First_Entity
(Loop_Ent
);
9419 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9422 Make_Subprogram_Body
(Loc
,
9424 Make_Procedure_Specification
(Loc
,
9425 Defining_Unit_Name
=> Local_Proc
),
9426 Declarations
=> Empty_List
,
9427 Handled_Statement_Sequence
=>
9428 Make_Handled_Sequence_Of_Statements
(Loc
,
9429 Statements
=> New_List
(Loop_Copy
)));
9431 Rewrite
(Loop_Stmt
, Local_Body
);
9432 Analyze
(Loop_Stmt
);
9434 Set_Has_Nested_Subprogram
(Local_Proc
);
9437 Make_Procedure_Call_Statement
(Loc
,
9438 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9440 Insert_After
(Loop_Stmt
, Local_Call
);
9441 Analyze
(Local_Call
);
9443 -- New procedure has the same scope as the original loop, and the scope
9444 -- of the loop is the new procedure.
9446 Set_Scope
(Local_Proc
, Scope
(Loop_Ent
));
9447 Set_Scope
(Loop_Ent
, Local_Proc
);
9449 Fixup_Inner_Scopes
(Loop_Copy
);
9451 -- The entity list of the new procedure is that of the loop
9453 Set_First_Entity
(Local_Proc
, Ent
);
9455 -- Note that the entities associated with the loop don't need to have
9456 -- their Scope fields reset, since they're still associated with the
9457 -- same loop entity that now belongs to the copied loop statement.
9460 ---------------------------
9461 -- Unnest_Statement_List --
9462 ---------------------------
9464 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
9465 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
9466 Local_Body
: Node_Id
;
9467 Local_Call
: Node_Id
;
9468 Local_Proc
: Entity_Id
;
9469 New_Stmts
: constant List_Id
:= Empty_List
;
9472 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9475 Make_Subprogram_Body
(Loc
,
9477 Make_Procedure_Specification
(Loc
,
9478 Defining_Unit_Name
=> Local_Proc
),
9479 Declarations
=> Empty_List
,
9480 Handled_Statement_Sequence
=>
9481 Make_Handled_Sequence_Of_Statements
(Loc
,
9482 Statements
=> Stmts
));
9484 Append_To
(New_Stmts
, Local_Body
);
9486 Analyze
(Local_Body
);
9488 Set_Has_Nested_Subprogram
(Local_Proc
);
9491 Make_Procedure_Call_Statement
(Loc
,
9492 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9494 Append_To
(New_Stmts
, Local_Call
);
9495 Analyze
(Local_Call
);
9497 -- Traverse the statements, and for any that are declarations or
9498 -- subprogram bodies that have entities, set the Scope of those
9499 -- entities to the new procedure's Entity_Id.
9502 Stmt
: Node_Id
:= First
(Stmts
);
9505 while Present
(Stmt
) loop
9506 case Nkind
(Stmt
) is
9508 | N_Renaming_Declaration
9510 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
9512 when N_Subprogram_Body
=>
9514 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
9525 end Unnest_Statement_List
;
9527 --------------------------------
9528 -- Wrap_Transient_Declaration --
9529 --------------------------------
9531 -- If a transient scope has been established during the processing of the
9532 -- Expression of an Object_Declaration, it is not possible to wrap the
9533 -- declaration into a transient block as usual case, otherwise the object
9534 -- would be itself declared in the wrong scope. Therefore, all entities (if
9535 -- any) defined in the transient block are moved to the proper enclosing
9536 -- scope. Furthermore, if they are controlled variables they are finalized
9537 -- right after the declaration. The finalization list of the transient
9538 -- scope is defined as a renaming of the enclosing one so during their
9539 -- initialization they will be attached to the proper finalization list.
9540 -- For instance, the following declaration :
9542 -- X : Typ := F (G (A), G (B));
9544 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9545 -- is expanded into :
9547 -- X : Typ := [ complex Expression-Action ];
9548 -- [Deep_]Finalize (_v1);
9549 -- [Deep_]Finalize (_v2);
9551 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9556 Curr_S
:= Current_Scope
;
9557 Encl_S
:= Scope
(Curr_S
);
9559 -- Insert all actions including cleanup generated while analyzing or
9560 -- expanding the transient context back into the tree. Manage the
9561 -- secondary stack when the object declaration appears in a library
9562 -- level package [body].
9564 Insert_Actions_In_Scope_Around
9568 Uses_Sec_Stack
(Curr_S
)
9569 and then Nkind
(N
) = N_Object_Declaration
9570 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
9571 and then Is_Library_Level_Entity
(Encl_S
));
9574 -- Relocate local entities declared within the transient scope to the
9575 -- enclosing scope. This action sets their Is_Public flag accordingly.
9577 Transfer_Entities
(Curr_S
, Encl_S
);
9579 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9580 -- is properly released upon exiting the said scope.
9582 if Uses_Sec_Stack
(Curr_S
) then
9583 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9585 -- Do not mark a function that returns on the secondary stack as the
9586 -- reclamation is done by the caller.
9588 if Ekind
(Curr_S
) = E_Function
9589 and then Needs_Secondary_Stack
(Etype
(Curr_S
))
9593 -- Otherwise mark the enclosing dynamic scope
9596 Set_Uses_Sec_Stack
(Curr_S
);
9597 Check_Restriction
(No_Secondary_Stack
, N
);
9600 end Wrap_Transient_Declaration
;
9602 -------------------------------
9603 -- Wrap_Transient_Expression --
9604 -------------------------------
9606 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9607 Loc
: constant Source_Ptr
:= Sloc
(N
);
9608 Expr
: Node_Id
:= Relocate_Node
(N
);
9609 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9610 Typ
: constant Entity_Id
:= Etype
(N
);
9617 -- M : constant Mark_Id := SS_Mark;
9618 -- procedure Finalizer is ... (See Build_Finalizer)
9621 -- Temp := <Expr>; -- general case
9622 -- Temp := (if <Expr> then True else False); -- boolean case
9628 -- A special case is made for Boolean expressions so that the back end
9629 -- knows to generate a conditional branch instruction, if running with
9630 -- -fpreserve-control-flow. This ensures that a control-flow change
9631 -- signaling the decision outcome occurs before the cleanup actions.
9633 if Opt
.Suppress_Control_Flow_Optimizations
9634 and then Is_Boolean_Type
(Typ
)
9637 Make_If_Expression
(Loc
,
9638 Expressions
=> New_List
(
9640 New_Occurrence_Of
(Standard_True
, Loc
),
9641 New_Occurrence_Of
(Standard_False
, Loc
)));
9644 Insert_Actions
(N
, New_List
(
9645 Make_Object_Declaration
(Loc
,
9646 Defining_Identifier
=> Temp
,
9647 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9649 Make_Transient_Block
(Loc
,
9651 Make_Assignment_Statement
(Loc
,
9652 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9653 Expression
=> Expr
),
9654 Par
=> Parent
(N
))));
9656 if Debug_Generated_Code
then
9657 Set_Debug_Info_Needed
(Temp
);
9660 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9661 Analyze_And_Resolve
(N
, Typ
);
9662 end Wrap_Transient_Expression
;
9664 ------------------------------
9665 -- Wrap_Transient_Statement --
9666 ------------------------------
9668 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9669 Loc
: constant Source_Ptr
:= Sloc
(N
);
9670 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9675 -- M : constant Mark_Id := SS_Mark;
9676 -- procedure Finalizer is ... (See Build_Finalizer)
9686 Make_Transient_Block
(Loc
,
9688 Par
=> Parent
(N
)));
9690 -- With the scope stack back to normal, we can call analyze on the
9691 -- resulting block. At this point, the transient scope is being
9692 -- treated like a perfectly normal scope, so there is nothing
9693 -- special about it.
9695 -- Note: Wrap_Transient_Statement is called with the node already
9696 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9697 -- otherwise we would get a recursive processing of the node when
9698 -- we do this Analyze call.
9701 end Wrap_Transient_Statement
;