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 -- Transient Scope Management --
75 --------------------------------
77 -- A transient scope is needed when certain temporary objects are created
78 -- by the compiler. These temporary objects are allocated on the secondary
79 -- stack and/or need finalization, and the transient scope is responsible
80 -- for finalizing the objects and reclaiming the memory of the secondary
81 -- stack at the appropriate time. They are generally objects allocated to
82 -- store the result of a function returning an unconstrained or controlled
83 -- value. Expressions needing to be wrapped in a transient scope may appear
84 -- in three different contexts which lead to different kinds of transient
87 -- 1. In a simple statement (procedure call, assignment, ...). In this
88 -- case the instruction is wrapped into a transient block. See
89 -- Wrap_Transient_Statement for details.
91 -- 2. In an expression of a control structure (test in a IF statement,
92 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
95 -- 3. In a expression of an object_declaration. No wrapping is possible
96 -- here, so the finalization actions, if any, are done right after the
97 -- declaration and the secondary stack deallocation is done in the
98 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
100 --------------------------------------------------
101 -- Transient Blocks and Finalization Management --
102 --------------------------------------------------
104 procedure Insert_Actions_In_Scope_Around
107 Manage_SS
: Boolean);
108 -- Insert the before-actions kept in the scope stack before N, and the
109 -- after-actions after N, which must be a member of a list. If flag Clean
110 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
111 -- calls to mark and release the secondary stack.
113 function Make_Transient_Block
116 Par
: Node_Id
) return Node_Id
;
117 -- Action is a single statement or object declaration. Par is the proper
118 -- parent of the generated block. Create a transient block whose name is
119 -- the current scope and the only handled statement is Action. If Action
120 -- involves controlled objects or secondary stack usage, the corresponding
121 -- cleanup actions are performed at the end of the block.
123 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
124 -- Shared processing for Store_xxx_Actions_In_Scope
126 -----------------------------
127 -- Finalization Management --
128 -----------------------------
130 -- This part describes how Initialization/Adjustment/Finalization
131 -- procedures are generated and called. Two cases must be considered: types
132 -- that are Controlled (Is_Controlled flag set) and composite types that
133 -- contain controlled components (Has_Controlled_Component flag set). In
134 -- the first case the procedures to call are the user-defined primitive
135 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
136 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
137 -- charge of calling the former procedures on the controlled components.
139 -- For records with Has_Controlled_Component set, a hidden "controller"
140 -- component is inserted. This controller component contains its own
141 -- finalization list on which all controlled components are attached
142 -- creating an indirection on the upper-level Finalization list. This
143 -- technique facilitates the management of objects whose number of
144 -- controlled components changes during execution. This controller
145 -- component is itself controlled and is attached to the upper-level
146 -- finalization chain. Its adjust primitive is in charge of calling adjust
147 -- on the components and adjusting the finalization pointer to match their
148 -- new location (see a-finali.adb).
150 -- It is not possible to use a similar technique for arrays that have
151 -- Has_Controlled_Component set. In this case, deep procedures are
152 -- generated that call initialize/adjust/finalize + attachment or
153 -- detachment on the finalization list for all component.
155 -- Initialize calls: they are generated for declarations or dynamic
156 -- allocations of Controlled objects with no initial value. They are always
157 -- followed by an attachment to the current Finalization Chain. For the
158 -- dynamic allocation case this the chain attached to the scope of the
159 -- access type definition otherwise, this is the chain of the current
162 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
163 -- or dynamic allocations of Controlled objects with an initial value.
164 -- (2) after an assignment. In the first case they are followed by an
165 -- attachment to the final chain, in the second case they are not.
167 -- Finalization Calls: They are generated on (1) scope exit, (2)
168 -- assignments, (3) unchecked deallocations. In case (3) they have to
169 -- be detached from the final chain, in case (2) they must not and in
170 -- case (1) this is not important since we are exiting the scope anyway.
174 -- Type extensions will have a new record controller at each derivation
175 -- level containing controlled components. The record controller for
176 -- the parent/ancestor is attached to the finalization list of the
177 -- extension's record controller (i.e. the parent is like a component
178 -- of the extension).
180 -- For types that are both Is_Controlled and Has_Controlled_Components,
181 -- the record controller and the object itself are handled separately.
182 -- It could seem simpler to attach the object at the end of its record
183 -- controller but this would not tackle view conversions properly.
185 -- A classwide type can always potentially have controlled components
186 -- but the record controller of the corresponding actual type may not
187 -- be known at compile time so the dispatch table contains a special
188 -- field that allows computation of the offset of the record controller
189 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
191 -- Here is a simple example of the expansion of a controlled block :
195 -- Y : Controlled := Init;
201 -- Z : R := (C => X);
211 -- _L : System.FI.Finalizable_Ptr;
213 -- procedure _Clean is
216 -- System.FI.Finalize_List (_L);
224 -- Attach_To_Final_List (_L, Finalizable (X), 1);
225 -- at end: Abort_Undefer;
226 -- Y : Controlled := Init;
228 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
236 -- Deep_Initialize (W, _L, 1);
237 -- at end: Abort_Under;
238 -- Z : R := (C => X);
239 -- Deep_Adjust (Z, _L, 1);
243 -- Deep_Finalize (W, False);
244 -- <save W's final pointers>
246 -- <restore W's final pointers>
247 -- Deep_Adjust (W, _L, 0);
252 type Final_Primitives
is
253 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
254 -- This enumeration type is defined in order to ease sharing code for
255 -- building finalization procedures for composite types.
257 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
258 (Initialize_Case
=> Name_Initialize
,
259 Adjust_Case
=> Name_Adjust
,
260 Finalize_Case
=> Name_Finalize
,
261 Address_Case
=> Name_Finalize_Address
);
262 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
263 (Initialize_Case
=> TSS_Deep_Initialize
,
264 Adjust_Case
=> TSS_Deep_Adjust
,
265 Finalize_Case
=> TSS_Deep_Finalize
,
266 Address_Case
=> TSS_Finalize_Address
);
268 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
269 -- Determine whether access type Typ may have a finalization master
271 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
272 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
273 -- Has_Controlled_Component set and store them using the TSS mechanism.
275 function Build_Cleanup_Statements
277 Additional_Cleanup
: List_Id
) return List_Id
;
278 -- Create the cleanup calls for an asynchronous call block, task master,
279 -- protected subprogram body, task allocation block or task body, or
280 -- additional cleanup actions parked on a transient block. If the context
281 -- does not contain the above constructs, the routine returns an empty
284 procedure Build_Finalizer
286 Clean_Stmts
: List_Id
;
289 Defer_Abort
: Boolean;
290 Fin_Id
: out Entity_Id
);
291 -- N may denote an accept statement, block, entry body, package body,
292 -- package spec, protected body, subprogram body, or a task body. Create
293 -- a procedure which contains finalization calls for all controlled objects
294 -- declared in the declarative or statement region of N. The calls are
295 -- built in reverse order relative to the original declarations. In the
296 -- case of a task body, the routine delays the creation of the finalizer
297 -- until all statements have been moved to the task body procedure.
298 -- Clean_Stmts may contain additional context-dependent code used to abort
299 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
300 -- Mark_Id is the secondary stack used in the current context or Empty if
301 -- missing. Top_Decls is the list on which the declaration of the finalizer
302 -- is attached in the non-package case. Defer_Abort indicates that the
303 -- statements passed in perform actions that require abort to be deferred,
304 -- such as for task termination. Fin_Id is the finalizer declaration
307 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
308 -- N is a construct that contains a handled sequence of statements, Fin_Id
309 -- is the entity of a finalizer. Create an At_End handler that covers the
310 -- statements of N and calls Fin_Id. If the handled statement sequence has
311 -- an exception handler, the statements will be wrapped in a block to avoid
312 -- unwanted interaction with the new At_End handler.
314 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
315 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
316 -- Has_Component_Component set and store them using the TSS mechanism.
318 -------------------------------------------
319 -- Unnesting procedures for CCG and LLVM --
320 -------------------------------------------
322 -- Expansion generates subprograms for controlled types management that
323 -- may appear in declarative lists in package declarations and bodies.
324 -- These subprograms appear within generated blocks that contain local
325 -- declarations and a call to finalization procedures. To ensure that
326 -- such subprograms get activation records when needed, we transform the
327 -- block into a procedure body, followed by a call to it in the same
330 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
331 -- The statement part of a package body that is a compilation unit may
332 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
333 -- Mode such subprograms must be handled as nested inside the (implicit)
334 -- elaboration procedure that executes that statement part. To handle
335 -- properly uplevel references we construct that subprogram explicitly,
336 -- to contain blocks and inner subprograms, the statement part becomes
337 -- a call to this subprogram. This is only done if blocks are present
338 -- in the statement list of the body. (It would be nice to unify this
339 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
340 -- they're doing very similar work, but are structured differently. ???)
342 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
343 -- Similarly, the declarations or statements in library-level packages may
344 -- have created blocks with nested subprograms. Such a block must be
345 -- transformed into a procedure followed by a call to it, so that unnesting
346 -- can handle uplevel references within these nested subprograms (typically
347 -- subprograms that handle finalization actions). This also applies to
348 -- nested packages, including instantiations, in which case it must
349 -- recursively process inner bodies.
351 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
352 -- Similarly, check for blocks with nested subprograms occurring within
353 -- a set of exception handlers associated with a package body N.
355 procedure Unnest_Block
(Decl
: Node_Id
);
356 -- Blocks that contain nested subprograms with up-level references need to
357 -- create activation records for them. We do this by rewriting the block as
358 -- a procedure, followed by a call to it in the same declarative list, to
359 -- replicate the semantics of the original block.
361 -- A common source for such block is a transient block created for a
362 -- construct (declaration, assignment, etc.) that involves controlled
363 -- actions or secondary-stack management, in which case the nested
364 -- subprogram is a finalizer.
366 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
367 -- The separate statement lists associated with an if-statement (then part,
368 -- elsif parts, else part) may require unnesting if they directly contain
369 -- a subprogram body that references up-level objects. Each statement list
370 -- is traversed to locate such subprogram bodies, and if a part's statement
371 -- list contains a body, then the list is replaced with a new procedure
372 -- containing the part's statements followed by a call to the procedure.
373 -- Furthermore, any nested blocks, loops, or if statements will also be
374 -- traversed to determine the need for further unnesting transformations.
376 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
377 -- A list of statements that directly contains a subprogram at its outer
378 -- level, that may reference objects declared in that same statement list,
379 -- is rewritten as a procedure containing the statement list Stmts (which
380 -- includes any such objects as well as the nested subprogram), followed by
381 -- a call to the new procedure, and Stmts becomes the list containing the
382 -- procedure and the call. This ensures that Unnest_Subprogram will later
383 -- properly handle up-level references from the nested subprogram to
384 -- objects declared earlier in statement list, by creating an activation
385 -- record and passing it to the nested subprogram. This procedure also
386 -- resets the Scope of objects declared in the statement list, as well as
387 -- the Scope of the nested subprogram, to refer to the new procedure.
388 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
389 -- only be called when known that the statement list contains a subprogram.
391 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
392 -- Top-level Loops that contain nested subprograms with up-level references
393 -- need to have activation records. We do this by rewriting the loop as a
394 -- procedure containing the loop, followed by a call to the procedure in
395 -- the same library-level declarative list, to replicate the semantics of
396 -- the original loop. Such loops can occur due to aggregate expansions and
399 procedure Check_Visibly_Controlled
400 (Prim
: Final_Primitives
;
402 E
: in out Entity_Id
;
403 Cref
: in out Node_Id
);
404 -- The controlled operation declared for a derived type may not be
405 -- overriding, if the controlled operations of the parent type are hidden,
406 -- for example when the parent is a private type whose full view is
407 -- controlled. For other primitive operations we modify the name of the
408 -- operation to indicate that it is not overriding, but this is not
409 -- possible for Initialize, etc. because they have to be retrievable by
410 -- name. Before generating the proper call to one of these operations we
411 -- check whether Typ is known to be controlled at the point of definition.
412 -- If it is not then we must retrieve the hidden operation of the parent
413 -- and use it instead. This is one case that might be solved more cleanly
414 -- once Overriding pragmas or declarations are in place.
416 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
417 -- Check recursively whether a loop or block contains a subprogram that
418 -- may need an activation record.
420 function Convert_View
423 Ind
: Pos
:= 1) return Node_Id
;
424 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
425 -- argument being passed to it. Ind indicates which formal of procedure
426 -- Proc we are trying to match. This function will, if necessary, generate
427 -- a conversion between the partial and full view of Arg to match the type
428 -- of the formal of Proc, or force a conversion to the class-wide type in
429 -- the case where the operation is abstract.
435 Skip_Self
: Boolean := False) return Node_Id
;
436 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
437 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
438 -- an adjust or finalization call. When flag Skip_Self is set, the related
439 -- action has an effect on the components only (if any).
441 function Make_Deep_Proc
442 (Prim
: Final_Primitives
;
444 Stmts
: List_Id
) return Entity_Id
;
445 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
446 -- Deep_Finalize procedures according to the first parameter. These
447 -- procedures operate on the type Typ. The Stmts parameter gives the
448 -- body of the procedure.
450 function Make_Deep_Array_Body
451 (Prim
: Final_Primitives
;
452 Typ
: Entity_Id
) return List_Id
;
453 -- This function generates the list of statements for implementing
454 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
455 -- the first parameter, these procedures operate on the array type Typ.
457 function Make_Deep_Record_Body
458 (Prim
: Final_Primitives
;
460 Is_Local
: Boolean := False) return List_Id
;
461 -- This function generates the list of statements for implementing
462 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
463 -- the first parameter, these procedures operate on the record type Typ.
464 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
465 -- whether the inner logic should be dictated by state counters.
467 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
468 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
469 -- Make_Deep_Record_Body. Generate the following statements:
472 -- type Acc_Typ is access all Typ;
473 -- for Acc_Typ'Storage_Size use 0;
475 -- [Deep_]Finalize (Acc_Typ (V).all);
478 --------------------------------
479 -- Allows_Finalization_Master --
480 --------------------------------
482 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
483 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
484 -- Determine whether entity E is inside a wrapper package created for
485 -- an instance of Ada.Unchecked_Deallocation.
487 ------------------------------
488 -- In_Deallocation_Instance --
489 ------------------------------
491 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
492 Pkg
: constant Entity_Id
:= Scope
(E
);
493 Par
: Node_Id
:= Empty
;
496 if Ekind
(Pkg
) = E_Package
497 and then Present
(Related_Instance
(Pkg
))
498 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
500 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
504 and then Chars
(Par
) = Name_Unchecked_Deallocation
505 and then Chars
(Scope
(Par
)) = Name_Ada
506 and then Scope
(Scope
(Par
)) = Standard_Standard
;
510 end In_Deallocation_Instance
;
514 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
515 Ptr_Typ
: constant Entity_Id
:=
516 Root_Type_Of_Full_View
(Base_Type
(Typ
));
518 -- Start of processing for Allows_Finalization_Master
521 -- Certain run-time configurations and targets do not provide support
522 -- for controlled types and therefore do not need masters.
524 if Restriction_Active
(No_Finalization
) then
527 -- Do not consider C and C++ types since it is assumed that the non-Ada
528 -- side will handle their cleanup.
530 elsif Convention
(Desig_Typ
) = Convention_C
531 or else Convention
(Desig_Typ
) = Convention_CPP
535 -- Do not consider an access type that returns on the secondary stack
537 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
538 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
542 -- Do not consider an access type that can never allocate an object
544 elsif No_Pool_Assigned
(Ptr_Typ
) then
547 -- Do not consider an access type coming from an Unchecked_Deallocation
548 -- instance. Even though the designated type may be controlled, the
549 -- access type will never participate in any allocations.
551 elsif In_Deallocation_Instance
(Ptr_Typ
) then
554 -- Do not consider a non-library access type when No_Nested_Finalization
555 -- is in effect since finalization masters are controlled objects and if
556 -- created will violate the restriction.
558 elsif Restriction_Active
(No_Nested_Finalization
)
559 and then not Is_Library_Level_Entity
(Ptr_Typ
)
563 -- Do not consider an access type subject to pragma No_Heap_Finalization
564 -- because objects allocated through such a type are not to be finalized
565 -- when the access type goes out of scope.
567 elsif No_Heap_Finalization
(Ptr_Typ
) then
570 -- Do not create finalization masters in GNATprove mode because this
571 -- causes unwanted extra expansion. A compilation in this mode must
572 -- keep the tree as close as possible to the original sources.
574 elsif GNATprove_Mode
then
577 -- Otherwise the access type may use a finalization master
582 end Allows_Finalization_Master
;
584 ----------------------------
585 -- Build_Anonymous_Master --
586 ----------------------------
588 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
589 function Create_Anonymous_Master
590 (Desig_Typ
: Entity_Id
;
592 Unit_Decl
: Node_Id
) return Entity_Id
;
593 -- Create a new anonymous master for access type Ptr_Typ with designated
594 -- type Desig_Typ. The declaration of the master and its initialization
595 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
596 -- the entity of Unit_Decl.
598 function Current_Anonymous_Master
599 (Desig_Typ
: Entity_Id
;
600 Unit_Id
: Entity_Id
) return Entity_Id
;
601 -- Find an anonymous master declared within unit Unit_Id which services
602 -- designated type Desig_Typ. If there is no such master, return Empty.
604 -----------------------------
605 -- Create_Anonymous_Master --
606 -----------------------------
608 function Create_Anonymous_Master
609 (Desig_Typ
: Entity_Id
;
611 Unit_Decl
: Node_Id
) return Entity_Id
613 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
624 -- <FM_Id> : Finalization_Master;
626 FM_Id
:= Make_Temporary
(Loc
, 'A');
629 Make_Object_Declaration
(Loc
,
630 Defining_Identifier
=> FM_Id
,
632 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
636 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
639 Make_Procedure_Call_Statement
(Loc
,
641 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
642 Parameter_Associations
=> New_List
(
643 New_Occurrence_Of
(FM_Id
, Loc
),
644 Make_Attribute_Reference
(Loc
,
646 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
647 Attribute_Name
=> Name_Unrestricted_Access
)));
649 -- Find the declarative list of the unit
651 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
652 Unit_Spec
:= Specification
(Unit_Decl
);
653 Decls
:= Visible_Declarations
(Unit_Spec
);
657 Set_Visible_Declarations
(Unit_Spec
, Decls
);
660 -- Package body or subprogram case
662 -- ??? A subprogram spec or body that acts as a compilation unit may
663 -- contain a formal parameter of an anonymous access-to-controlled
664 -- type initialized by an allocator.
666 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
668 -- There is no suitable place to create the master as the subprogram
669 -- is not in a declarative list.
672 Decls
:= Declarations
(Unit_Decl
);
676 Set_Declarations
(Unit_Decl
, Decls
);
680 Prepend_To
(Decls
, FM_Init
);
681 Prepend_To
(Decls
, FM_Decl
);
683 -- Use the scope of the unit when analyzing the declaration of the
684 -- master and its initialization actions.
686 Push_Scope
(Unit_Id
);
691 -- Mark the master as servicing this specific designated type
693 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
695 -- Include the anonymous master in the list of existing masters which
696 -- appear in this unit. This effectively creates a mapping between a
697 -- master and a designated type which in turn allows for the reuse of
698 -- masters on a per-unit basis.
700 All_FMs
:= Anonymous_Masters
(Unit_Id
);
703 All_FMs
:= New_Elmt_List
;
704 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
707 Prepend_Elmt
(FM_Id
, All_FMs
);
710 end Create_Anonymous_Master
;
712 ------------------------------
713 -- Current_Anonymous_Master --
714 ------------------------------
716 function Current_Anonymous_Master
717 (Desig_Typ
: Entity_Id
;
718 Unit_Id
: Entity_Id
) return Entity_Id
720 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
725 -- Inspect the list of anonymous masters declared within the unit
726 -- looking for an existing master which services the same designated
729 if Present
(All_FMs
) then
730 FM_Elmt
:= First_Elmt
(All_FMs
);
731 while Present
(FM_Elmt
) loop
732 FM_Id
:= Node
(FM_Elmt
);
734 -- The currect master services the same designated type. As a
735 -- result the master can be reused and associated with another
736 -- anonymous access-to-controlled type.
738 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
747 end Current_Anonymous_Master
;
751 Desig_Typ
: Entity_Id
;
753 Priv_View
: Entity_Id
;
757 -- Start of processing for Build_Anonymous_Master
760 -- Nothing to do if the circumstances do not allow for a finalization
763 if not Allows_Finalization_Master
(Ptr_Typ
) then
767 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
768 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
770 -- The compilation unit is a package instantiation. In this case the
771 -- anonymous master is associated with the package spec as both the
772 -- spec and body appear at the same level.
774 if Nkind
(Unit_Decl
) = N_Package_Body
775 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
777 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
778 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
781 -- Use the initial declaration of the designated type when it denotes
782 -- the full view of an incomplete or private type. This ensures that
783 -- types with one and two views are treated the same.
785 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
786 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
788 if Present
(Priv_View
) then
789 Desig_Typ
:= Priv_View
;
792 -- Determine whether the current semantic unit already has an anonymous
793 -- master which services the designated type.
795 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
797 -- If this is not the case, create a new master
800 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
803 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
804 end Build_Anonymous_Master
;
806 ----------------------------
807 -- Build_Array_Deep_Procs --
808 ----------------------------
810 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
814 (Prim
=> Initialize_Case
,
816 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
818 if not Is_Limited_View
(Typ
) then
821 (Prim
=> Adjust_Case
,
823 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
826 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
827 -- suppressed since these routine will not be used.
829 if not Restriction_Active
(No_Finalization
) then
832 (Prim
=> Finalize_Case
,
834 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
836 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
838 if not CodePeer_Mode
then
841 (Prim
=> Address_Case
,
843 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
846 end Build_Array_Deep_Procs
;
848 ------------------------------
849 -- Build_Cleanup_Statements --
850 ------------------------------
852 function Build_Cleanup_Statements
854 Additional_Cleanup
: List_Id
) return List_Id
856 Is_Asynchronous_Call
: constant Boolean :=
857 Nkind
(N
) = N_Block_Statement
and then Is_Asynchronous_Call_Block
(N
);
858 Is_Master
: constant Boolean :=
859 Nkind
(N
) /= N_Entry_Body
and then Is_Task_Master
(N
);
860 Is_Protected_Subp_Body
: constant Boolean :=
861 Nkind
(N
) = N_Subprogram_Body
862 and then Is_Protected_Subprogram_Body
(N
);
863 Is_Task_Allocation
: constant Boolean :=
864 Nkind
(N
) = N_Block_Statement
and then Is_Task_Allocation_Block
(N
);
865 Is_Task_Body
: constant Boolean :=
866 Nkind
(Original_Node
(N
)) = N_Task_Body
;
868 Loc
: constant Source_Ptr
:= Sloc
(N
);
869 Stmts
: constant List_Id
:= New_List
;
873 if Restricted_Profile
then
875 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
877 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
881 if Restriction_Active
(No_Task_Hierarchy
) = False then
882 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
885 -- Add statements to unlock the protected object parameter and to
886 -- undefer abort. If the context is a protected procedure and the object
887 -- has entries, call the entry service routine.
889 -- NOTE: The generated code references _object, a parameter to the
892 elsif Is_Protected_Subp_Body
then
894 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
895 Conc_Typ
: Entity_Id
:= Empty
;
897 Param_Typ
: Entity_Id
;
900 -- Find the _object parameter representing the protected object
902 Param
:= First
(Parameter_Specifications
(Spec
));
904 Param_Typ
:= Etype
(Parameter_Type
(Param
));
906 if Ekind
(Param_Typ
) = E_Record_Type
then
907 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
910 exit when No
(Param
) or else Present
(Conc_Typ
);
914 pragma Assert
(Present
(Param
));
915 pragma Assert
(Present
(Conc_Typ
));
917 Build_Protected_Subprogram_Call_Cleanup
918 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
921 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
922 -- tasks. Other unactivated tasks are completed by Complete_Task or
925 -- NOTE: The generated code references _chain, a local object
927 elsif Is_Task_Allocation
then
930 -- Expunge_Unactivated_Tasks (_chain);
932 -- where _chain is the list of tasks created by the allocator but not
933 -- yet activated. This list will be empty unless the block completes
937 Make_Procedure_Call_Statement
(Loc
,
940 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
941 Parameter_Associations
=> New_List
(
942 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
944 -- Attempt to cancel an asynchronous entry call whenever the block which
945 -- contains the abortable part is exited.
947 -- NOTE: The generated code references Cnn, a local object
949 elsif Is_Asynchronous_Call
then
951 Cancel_Param
: constant Entity_Id
:=
952 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
955 -- If it is of type Communication_Block, this must be a protected
956 -- entry call. Generate:
958 -- if Enqueued (Cancel_Param) then
959 -- Cancel_Protected_Entry_Call (Cancel_Param);
962 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
964 Make_If_Statement
(Loc
,
966 Make_Function_Call
(Loc
,
968 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
969 Parameter_Associations
=> New_List
(
970 New_Occurrence_Of
(Cancel_Param
, Loc
))),
972 Then_Statements
=> New_List
(
973 Make_Procedure_Call_Statement
(Loc
,
976 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
977 Parameter_Associations
=> New_List
(
978 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
980 -- Asynchronous delay, generate:
981 -- Cancel_Async_Delay (Cancel_Param);
983 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
985 Make_Procedure_Call_Statement
(Loc
,
987 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
988 Parameter_Associations
=> New_List
(
989 Make_Attribute_Reference
(Loc
,
991 New_Occurrence_Of
(Cancel_Param
, Loc
),
992 Attribute_Name
=> Name_Unchecked_Access
))));
994 -- Task entry call, generate:
995 -- Cancel_Task_Entry_Call (Cancel_Param);
999 Make_Procedure_Call_Statement
(Loc
,
1001 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
1002 Parameter_Associations
=> New_List
(
1003 New_Occurrence_Of
(Cancel_Param
, Loc
))));
1008 Append_List_To
(Stmts
, Additional_Cleanup
);
1010 end Build_Cleanup_Statements
;
1012 -----------------------------
1013 -- Build_Controlling_Procs --
1014 -----------------------------
1016 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
1018 if Is_Array_Type
(Typ
) then
1019 Build_Array_Deep_Procs
(Typ
);
1020 else pragma Assert
(Is_Record_Type
(Typ
));
1021 Build_Record_Deep_Procs
(Typ
);
1023 end Build_Controlling_Procs
;
1025 -----------------------------
1026 -- Build_Exception_Handler --
1027 -----------------------------
1029 function Build_Exception_Handler
1030 (Data
: Finalization_Exception_Data
;
1031 For_Library
: Boolean := False) return Node_Id
1034 Proc_To_Call
: Entity_Id
;
1039 pragma Assert
(Present
(Data
.Raised_Id
));
1041 if Exception_Extra_Info
1042 or else (For_Library
and not Restricted_Profile
)
1044 if Exception_Extra_Info
then
1048 -- Get_Current_Excep.all
1051 Make_Function_Call
(Data
.Loc
,
1053 Make_Explicit_Dereference
(Data
.Loc
,
1056 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1063 Except
:= Make_Null
(Data
.Loc
);
1066 if For_Library
and then not Restricted_Profile
then
1067 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1068 Actuals
:= New_List
(Except
);
1071 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1073 -- The dereference occurs only when Exception_Extra_Info is true,
1074 -- and therefore Except is not null.
1078 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1079 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1085 -- if not Raised_Id then
1086 -- Raised_Id := True;
1088 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1090 -- Save_Library_Occurrence (Get_Current_Excep.all);
1095 Make_If_Statement
(Data
.Loc
,
1097 Make_Op_Not
(Data
.Loc
,
1098 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1100 Then_Statements
=> New_List
(
1101 Make_Assignment_Statement
(Data
.Loc
,
1102 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1103 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1105 Make_Procedure_Call_Statement
(Data
.Loc
,
1107 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1108 Parameter_Associations
=> Actuals
))));
1113 -- Raised_Id := True;
1116 Make_Assignment_Statement
(Data
.Loc
,
1117 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1118 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1126 Make_Exception_Handler
(Data
.Loc
,
1127 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1128 Statements
=> Stmts
);
1129 end Build_Exception_Handler
;
1131 -------------------------------
1132 -- Build_Finalization_Master --
1133 -------------------------------
1135 procedure Build_Finalization_Master
1137 For_Lib_Level
: Boolean := False;
1138 For_Private
: Boolean := False;
1139 Context_Scope
: Entity_Id
:= Empty
;
1140 Insertion_Node
: Node_Id
:= Empty
)
1142 procedure Add_Pending_Access_Type
1144 Ptr_Typ
: Entity_Id
);
1145 -- Add access type Ptr_Typ to the pending access type list for type Typ
1147 -----------------------------
1148 -- Add_Pending_Access_Type --
1149 -----------------------------
1151 procedure Add_Pending_Access_Type
1153 Ptr_Typ
: Entity_Id
)
1158 if Present
(Pending_Access_Types
(Typ
)) then
1159 List
:= Pending_Access_Types
(Typ
);
1161 List
:= New_Elmt_List
;
1162 Set_Pending_Access_Types
(Typ
, List
);
1165 Prepend_Elmt
(Ptr_Typ
, List
);
1166 end Add_Pending_Access_Type
;
1170 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1172 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1173 -- A finalization master created for a named access type is associated
1174 -- with the full view (if applicable) as a consequence of freezing. The
1175 -- full view criteria does not apply to anonymous access types because
1176 -- those cannot have a private and a full view.
1178 -- Start of processing for Build_Finalization_Master
1181 -- Nothing to do if the circumstances do not allow for a finalization
1184 if not Allows_Finalization_Master
(Typ
) then
1187 -- Various machinery such as freezing may have already created a
1188 -- finalization master.
1190 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1195 Actions
: constant List_Id
:= New_List
;
1196 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1197 Fin_Mas_Id
: Entity_Id
;
1198 Pool_Id
: Entity_Id
;
1201 -- Source access types use fixed master names since the master is
1202 -- inserted in the same source unit only once. The only exception to
1203 -- this are instances using the same access type as generic actual.
1205 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1207 Make_Defining_Identifier
(Loc
,
1208 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1210 -- Internally generated access types use temporaries as their names
1211 -- due to possible collision with identical names coming from other
1215 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1218 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1221 -- <Ptr_Typ>FM : aliased Finalization_Master;
1224 Make_Object_Declaration
(Loc
,
1225 Defining_Identifier
=> Fin_Mas_Id
,
1226 Aliased_Present
=> True,
1227 Object_Definition
=>
1228 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1230 if Debug_Generated_Code
then
1231 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1234 -- Set the associated pool and primitive Finalize_Address of the new
1235 -- finalization master.
1237 -- The access type has a user-defined storage pool, use it
1239 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1240 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1242 -- Otherwise the default choice is the global storage pool
1245 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1246 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1250 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1253 Make_Procedure_Call_Statement
(Loc
,
1255 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1256 Parameter_Associations
=> New_List
(
1257 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1258 Make_Attribute_Reference
(Loc
,
1259 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1260 Attribute_Name
=> Name_Unrestricted_Access
))));
1262 -- Finalize_Address is not generated in CodePeer mode because the
1263 -- body contains address arithmetic. Skip this step.
1265 if CodePeer_Mode
then
1268 -- Associate the Finalize_Address primitive of the designated type
1269 -- with the finalization master of the access type. The designated
1270 -- type must be forzen as Finalize_Address is generated when the
1271 -- freeze node is expanded.
1273 elsif Is_Frozen
(Desig_Typ
)
1274 and then Present
(Finalize_Address
(Desig_Typ
))
1276 -- The finalization master of an anonymous access type may need
1277 -- to be inserted in a specific place in the tree. For instance:
1281 -- <finalization master of "access Comp_Typ">
1283 -- type Rec_Typ is record
1284 -- Comp : access Comp_Typ;
1287 -- <freeze node for Comp_Typ>
1288 -- <freeze node for Rec_Typ>
1290 -- Due to this oddity, the anonymous access type is stored for
1291 -- later processing (see below).
1293 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1296 -- Set_Finalize_Address
1297 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1300 Make_Set_Finalize_Address_Call
1302 Ptr_Typ
=> Ptr_Typ
));
1304 -- Otherwise the designated type is either anonymous access or a
1305 -- Taft-amendment type and has not been frozen. Store the access
1306 -- type for later processing (see Freeze_Type).
1309 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1312 -- A finalization master created for an access designating a type
1313 -- with private components is inserted before a context-dependent
1318 -- At this point both the scope of the context and the insertion
1319 -- mode must be known.
1321 pragma Assert
(Present
(Context_Scope
));
1322 pragma Assert
(Present
(Insertion_Node
));
1324 Push_Scope
(Context_Scope
);
1326 -- Treat use clauses as declarations and insert directly in front
1329 if Nkind
(Insertion_Node
) in
1330 N_Use_Package_Clause | N_Use_Type_Clause
1332 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1334 Insert_Actions
(Insertion_Node
, Actions
);
1339 -- The finalization master belongs to an access result type related
1340 -- to a build-in-place function call used to initialize a library
1341 -- level object. The master must be inserted in front of the access
1342 -- result type declaration denoted by Insertion_Node.
1344 elsif For_Lib_Level
then
1345 pragma Assert
(Present
(Insertion_Node
));
1346 Insert_Actions
(Insertion_Node
, Actions
);
1348 -- Otherwise the finalization master and its initialization become a
1349 -- part of the freeze node.
1352 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1355 Analyze_List
(Actions
);
1357 -- When the type the finalization master is being generated for was
1358 -- created to store a 'Old object, then mark it as such so its
1359 -- finalization can be delayed until after postconditions have been
1362 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1363 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1366 end Build_Finalization_Master
;
1368 ---------------------
1369 -- Build_Finalizer --
1370 ---------------------
1372 procedure Build_Finalizer
1374 Clean_Stmts
: List_Id
;
1375 Mark_Id
: Entity_Id
;
1376 Top_Decls
: List_Id
;
1377 Defer_Abort
: Boolean;
1378 Fin_Id
: out Entity_Id
)
1380 Acts_As_Clean
: constant Boolean :=
1383 (Present
(Clean_Stmts
)
1384 and then Is_Non_Empty_List
(Clean_Stmts
));
1386 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1387 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1388 For_Package
: constant Boolean :=
1389 For_Package_Body
or else For_Package_Spec
;
1390 Loc
: constant Source_Ptr
:= Sloc
(N
);
1392 -- NOTE: Local variable declarations are conservative and do not create
1393 -- structures right from the start. Entities and lists are created once
1394 -- it has been established that N has at least one controlled object.
1396 Components_Built
: Boolean := False;
1397 -- A flag used to avoid double initialization of entities and lists. If
1398 -- the flag is set then the following variables have been initialized:
1404 Counter_Id
: Entity_Id
:= Empty
;
1405 Counter_Val
: Nat
:= 0;
1406 -- Name and value of the state counter
1408 Decls
: List_Id
:= No_List
;
1409 -- Declarative region of N (if available). If N is a package declaration
1410 -- Decls denotes the visible declarations.
1412 Finalizer_Data
: Finalization_Exception_Data
;
1413 -- Data for the exception
1415 Finalizer_Decls
: List_Id
:= No_List
;
1416 -- Local variable declarations. This list holds the label declarations
1417 -- of all jump block alternatives as well as the declaration of the
1418 -- local exception occurrence and the raised flag:
1419 -- E : Exception_Occurrence;
1420 -- Raised : Boolean := False;
1421 -- L<counter value> : label;
1423 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1424 -- Insertion point for the finalizer body. Depending on the context
1425 -- (Nkind of N) and the individual grouping of controlled objects, this
1426 -- node may denote a package declaration or body, package instantiation,
1427 -- block statement or a counter update statement.
1429 Finalizer_Stmts
: List_Id
:= No_List
;
1430 -- The statement list of the finalizer body. It contains the following:
1432 -- Abort_Defer; -- Added if abort is allowed
1433 -- <call to Prev_At_End> -- Added if exists
1434 -- <cleanup statements> -- Added if Acts_As_Clean
1435 -- <jump block> -- Added if Has_Ctrl_Objs
1436 -- <finalization statements> -- Added if Has_Ctrl_Objs
1437 -- <stack release> -- Added if Mark_Id exists
1438 -- Abort_Undefer; -- Added if abort is allowed
1440 Has_Ctrl_Objs
: Boolean := False;
1441 -- A general flag which denotes whether N has at least one controlled
1444 Has_Tagged_Types
: Boolean := False;
1445 -- A general flag which indicates whether N has at least one library-
1446 -- level tagged type declaration.
1448 HSS
: Node_Id
:= Empty
;
1449 -- The sequence of statements of N (if available)
1451 Jump_Alts
: List_Id
:= No_List
;
1452 -- Jump block alternatives. Depending on the value of the state counter,
1453 -- the control flow jumps to a sequence of finalization statements. This
1454 -- list contains the following:
1456 -- when <counter value> =>
1457 -- goto L<counter value>;
1459 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1460 -- Specific point in the finalizer statements where the jump block is
1463 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1464 -- The last controlled construct encountered when processing the top
1465 -- level lists of N. This can be a nested package, an instantiation or
1466 -- an object declaration.
1468 Prev_At_End
: Entity_Id
:= Empty
;
1469 -- The previous at end procedure of the handled statements block of N
1471 Priv_Decls
: List_Id
:= No_List
;
1472 -- The private declarations of N if N is a package declaration
1474 Spec_Id
: Entity_Id
:= Empty
;
1475 Spec_Decls
: List_Id
:= Top_Decls
;
1476 Stmts
: List_Id
:= No_List
;
1478 Tagged_Type_Stmts
: List_Id
:= No_List
;
1479 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1480 -- tagged types found in N.
1482 -----------------------
1483 -- Local subprograms --
1484 -----------------------
1486 procedure Build_Components
;
1487 -- Create all entites and initialize all lists used in the creation of
1490 procedure Create_Finalizer
;
1491 -- Create the spec and body of the finalizer and insert them in the
1492 -- proper place in the tree depending on the context.
1494 function New_Finalizer_Name
1495 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1496 -- Create a fully qualified name of a package spec or body finalizer.
1497 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1499 procedure Process_Declarations
1501 Preprocess
: Boolean := False;
1502 Top_Level
: Boolean := False);
1503 -- Inspect a list of declarations or statements which may contain
1504 -- objects that need finalization. When flag Preprocess is set, the
1505 -- routine will simply count the total number of controlled objects in
1506 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1507 -- when Preprocess is set and if True, the processing is performed for
1508 -- objects in nested package declarations or instances.
1510 procedure Process_Object_Declaration
1512 Has_No_Init
: Boolean := False;
1513 Is_Protected
: Boolean := False);
1514 -- Generate all the machinery associated with the finalization of a
1515 -- single object. Flag Has_No_Init is used to denote certain contexts
1516 -- where Decl does not have initialization call(s). Flag Is_Protected
1517 -- is set when Decl denotes a simple protected object.
1519 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1520 -- Generate all the code necessary to unregister the external tag of a
1523 ----------------------
1524 -- Build_Components --
1525 ----------------------
1527 procedure Build_Components
is
1528 Counter_Decl
: Node_Id
;
1529 Counter_Typ
: Entity_Id
;
1530 Counter_Typ_Decl
: Node_Id
;
1533 pragma Assert
(Present
(Decls
));
1535 -- This routine might be invoked several times when dealing with
1536 -- constructs that have two lists (either two declarative regions
1537 -- or declarations and statements). Avoid double initialization.
1539 if Components_Built
then
1543 Components_Built
:= True;
1545 if Has_Ctrl_Objs
then
1547 -- Create entities for the counter, its type, the local exception
1548 -- and the raised flag.
1550 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1551 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1553 Finalizer_Decls
:= New_List
;
1555 Build_Object_Declarations
1556 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1558 -- Since the total number of controlled objects is always known,
1559 -- build a subtype of Natural with precise bounds. This allows
1560 -- the backend to optimize the case statement. Generate:
1562 -- subtype Tnn is Natural range 0 .. Counter_Val;
1565 Make_Subtype_Declaration
(Loc
,
1566 Defining_Identifier
=> Counter_Typ
,
1567 Subtype_Indication
=>
1568 Make_Subtype_Indication
(Loc
,
1569 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1571 Make_Range_Constraint
(Loc
,
1575 Make_Integer_Literal
(Loc
, Uint_0
),
1577 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1579 -- Generate the declaration of the counter itself:
1581 -- Counter : Integer := 0;
1584 Make_Object_Declaration
(Loc
,
1585 Defining_Identifier
=> Counter_Id
,
1586 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1587 Expression
=> Make_Integer_Literal
(Loc
, 0));
1589 -- Set the type of the counter explicitly to prevent errors when
1590 -- examining object declarations later on.
1592 Set_Etype
(Counter_Id
, Counter_Typ
);
1594 if Debug_Generated_Code
then
1595 Set_Debug_Info_Needed
(Counter_Id
);
1598 -- The counter and its type are inserted before the source
1599 -- declarations of N.
1601 Prepend_To
(Decls
, Counter_Decl
);
1602 Prepend_To
(Decls
, Counter_Typ_Decl
);
1604 -- The counter and its associated type must be manually analyzed
1605 -- since N has already been analyzed. Use the scope of the spec
1606 -- when inserting in a package.
1609 Push_Scope
(Spec_Id
);
1610 Analyze
(Counter_Typ_Decl
);
1611 Analyze
(Counter_Decl
);
1615 Analyze
(Counter_Typ_Decl
);
1616 Analyze
(Counter_Decl
);
1619 Jump_Alts
:= New_List
;
1622 -- If the context requires additional cleanup, the finalization
1623 -- machinery is added after the cleanup code.
1625 if Acts_As_Clean
then
1626 Finalizer_Stmts
:= Clean_Stmts
;
1627 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1629 Finalizer_Stmts
:= New_List
;
1632 if Has_Tagged_Types
then
1633 Tagged_Type_Stmts
:= New_List
;
1635 end Build_Components
;
1637 ----------------------
1638 -- Create_Finalizer --
1639 ----------------------
1641 procedure Create_Finalizer
is
1642 Body_Id
: Entity_Id
;
1645 Jump_Block
: Node_Id
;
1647 Label_Id
: Entity_Id
;
1650 -- Step 1: Creation of the finalizer name
1652 -- Packages must use a distinct name for their finalizers since the
1653 -- binder will have to generate calls to them by name. The name is
1654 -- of the following form:
1656 -- xx__yy__finalize_[spec|body]
1659 Fin_Id
:= Make_Defining_Identifier
1660 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1661 Set_Has_Qualified_Name
(Fin_Id
);
1662 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1664 -- The default name is _finalizer
1667 -- Generation of a finalization procedure exclusively for 'Old
1668 -- interally generated constants requires different name since
1669 -- there will need to be multiple finalization routines in the
1670 -- same scope. See Build_Finalizer for details.
1673 Make_Defining_Identifier
(Loc
,
1674 Chars
=> New_External_Name
(Name_uFinalizer
));
1676 -- The visibility semantics of AT_END handlers force a strange
1677 -- separation of spec and body for stack-related finalizers:
1679 -- declare : Enclosing_Scope
1680 -- procedure _finalizer;
1682 -- <controlled objects>
1683 -- procedure _finalizer is
1689 -- Both spec and body are within the same construct and scope, but
1690 -- the body is part of the handled sequence of statements. This
1691 -- placement confuses the elaboration mechanism on targets where
1692 -- AT_END handlers are expanded into "when all others" handlers:
1695 -- when all others =>
1696 -- _finalizer; -- appears to require elab checks
1701 -- Since the compiler guarantees that the body of a _finalizer is
1702 -- always inserted in the same construct where the AT_END handler
1703 -- resides, there is no need for elaboration checks.
1705 Set_Kill_Elaboration_Checks
(Fin_Id
);
1707 -- Inlining the finalizer produces a substantial speedup at -O2.
1708 -- It is inlined by default at -O3. Either way, it is called
1709 -- exactly twice (once on the normal path, and once for
1710 -- exceptions/abort), so this won't bloat the code too much.
1712 Set_Is_Inlined
(Fin_Id
);
1715 if Debug_Generated_Code
then
1716 Set_Debug_Info_Needed
(Fin_Id
);
1719 -- Step 2: Creation of the finalizer specification
1722 -- procedure Fin_Id;
1725 Make_Subprogram_Declaration
(Loc
,
1727 Make_Procedure_Specification
(Loc
,
1728 Defining_Unit_Name
=> Fin_Id
));
1731 Set_Is_Exported
(Fin_Id
);
1732 Set_Interface_Name
(Fin_Id
,
1733 Make_String_Literal
(Loc
,
1734 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1737 -- Step 3: Creation of the finalizer body
1739 -- Has_Ctrl_Objs might be set because of a generic package body having
1740 -- controlled objects. In this case, Jump_Alts may be empty and no
1741 -- case nor goto statements are needed.
1744 and then not Is_Empty_List
(Jump_Alts
)
1746 -- Add L0, the default destination to the jump block
1748 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1749 Set_Entity
(Label_Id
,
1750 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1751 Label
:= Make_Label
(Loc
, Label_Id
);
1756 Prepend_To
(Finalizer_Decls
,
1757 Make_Implicit_Label_Declaration
(Loc
,
1758 Defining_Identifier
=> Entity
(Label_Id
),
1759 Label_Construct
=> Label
));
1765 Append_To
(Jump_Alts
,
1766 Make_Case_Statement_Alternative
(Loc
,
1767 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1768 Statements
=> New_List
(
1769 Make_Goto_Statement
(Loc
,
1770 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1775 Append_To
(Finalizer_Stmts
, Label
);
1777 -- Create the jump block which controls the finalization flow
1778 -- depending on the value of the state counter.
1781 Make_Case_Statement
(Loc
,
1782 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1783 Alternatives
=> Jump_Alts
);
1785 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1786 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1788 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1792 -- Add the library-level tagged type unregistration machinery before
1793 -- the jump block circuitry. This ensures that external tags will be
1794 -- removed even if a finalization exception occurs at some point.
1796 if Has_Tagged_Types
then
1797 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1800 -- Add a call to the previous At_End handler if it exists. The call
1801 -- must always precede the jump block.
1803 if Present
(Prev_At_End
) then
1804 Prepend_To
(Finalizer_Stmts
,
1805 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1807 -- Clear the At_End handler since we have already generated the
1808 -- proper replacement call for it.
1810 Set_At_End_Proc
(HSS
, Empty
);
1813 -- Release the secondary stack
1815 if Present
(Mark_Id
) then
1817 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1820 -- If the context is a build-in-place function, the secondary
1821 -- stack must be released, unless the build-in-place function
1822 -- itself is returning on the secondary stack. Generate:
1824 -- if BIP_Alloc_Form /= Secondary_Stack then
1825 -- SS_Release (Mark_Id);
1828 -- Note that if the function returns on the secondary stack,
1829 -- then the responsibility of reclaiming the space is always
1830 -- left to the caller (recursively if needed).
1832 if Nkind
(N
) = N_Subprogram_Body
then
1834 Spec_Id
: constant Entity_Id
:=
1835 Unique_Defining_Entity
(N
);
1836 BIP_SS
: constant Boolean :=
1837 Is_Build_In_Place_Function
(Spec_Id
)
1838 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1842 Make_If_Statement
(Loc
,
1847 (Build_In_Place_Formal
1848 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1850 Make_Integer_Literal
(Loc
,
1852 (BIP_Allocation_Form
'Pos
1853 (Secondary_Stack
)))),
1855 Then_Statements
=> New_List
(Release
));
1860 Append_To
(Finalizer_Stmts
, Release
);
1864 -- Protect the statements with abort defer/undefer. This is only when
1865 -- aborts are allowed and the cleanup statements require deferral or
1866 -- there are controlled objects to be finalized. Note that the abort
1867 -- defer/undefer pair does not require an extra block because each
1868 -- finalization exception is caught in its corresponding finalization
1869 -- block. As a result, the call to Abort_Defer always takes place.
1871 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1872 Prepend_To
(Finalizer_Stmts
,
1873 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1875 Append_To
(Finalizer_Stmts
,
1876 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1879 -- The local exception does not need to be reraised for library-level
1880 -- finalizers. Note that this action must be carried out after object
1881 -- cleanup, secondary stack release, and abort undeferral. Generate:
1883 -- if Raised and then not Abort then
1884 -- Raise_From_Controlled_Operation (E);
1887 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1888 Append_To
(Finalizer_Stmts
,
1889 Build_Raise_Statement
(Finalizer_Data
));
1893 -- procedure Fin_Id is
1894 -- Abort : constant Boolean := Triggered_By_Abort;
1896 -- Abort : constant Boolean := False; -- no abort
1898 -- E : Exception_Occurrence; -- All added if flag
1899 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1905 -- Abort_Defer; -- Added if abort is allowed
1906 -- <call to Prev_At_End> -- Added if exists
1907 -- <cleanup statements> -- Added if Acts_As_Clean
1908 -- <jump block> -- Added if Has_Ctrl_Objs
1909 -- <finalization statements> -- Added if Has_Ctrl_Objs
1910 -- <stack release> -- Added if Mark_Id exists
1911 -- Abort_Undefer; -- Added if abort is allowed
1912 -- <exception propagation> -- Added if Has_Ctrl_Objs
1915 -- Create the body of the finalizer
1917 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1919 if Debug_Generated_Code
then
1920 Set_Debug_Info_Needed
(Body_Id
);
1924 Set_Has_Qualified_Name
(Body_Id
);
1925 Set_Has_Fully_Qualified_Name
(Body_Id
);
1929 Make_Subprogram_Body
(Loc
,
1931 Make_Procedure_Specification
(Loc
,
1932 Defining_Unit_Name
=> Body_Id
),
1933 Declarations
=> Finalizer_Decls
,
1934 Handled_Statement_Sequence
=>
1935 Make_Handled_Sequence_Of_Statements
(Loc
,
1936 Statements
=> Finalizer_Stmts
));
1938 -- Step 4: Spec and body insertion, analysis
1942 -- If the package spec has private declarations, the finalizer
1943 -- body must be added to the end of the list in order to have
1944 -- visibility of all private controlled objects.
1946 if For_Package_Spec
then
1947 if Present
(Priv_Decls
) then
1948 Append_To
(Priv_Decls
, Fin_Spec
);
1949 Append_To
(Priv_Decls
, Fin_Body
);
1951 Append_To
(Decls
, Fin_Spec
);
1952 Append_To
(Decls
, Fin_Body
);
1955 -- For package bodies, both the finalizer spec and body are
1956 -- inserted at the end of the package declarations.
1959 Append_To
(Decls
, Fin_Spec
);
1960 Append_To
(Decls
, Fin_Body
);
1963 -- Push the name of the package
1965 Push_Scope
(Spec_Id
);
1973 -- Create the spec for the finalizer. The At_End handler must be
1974 -- able to call the body which resides in a nested structure.
1978 -- procedure Fin_Id; -- Spec
1980 -- <objects and possibly statements>
1981 -- procedure Fin_Id is ... -- Body
1984 -- Fin_Id; -- At_End handler
1987 pragma Assert
(Present
(Spec_Decls
));
1989 -- It maybe possible that we are finalizing 'Old objects which
1990 -- exist in the spec declarations. When this is the case the
1991 -- Finalizer_Insert_Node will come before the end of the
1992 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1993 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1994 -- end of Spec_Decls to prevent its body appearing before its
1995 -- corresponding spec.
1997 if Present
(Finalizer_Insert_Nod
)
1998 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
2000 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
2001 Finalizer_Insert_Nod
:= Fin_Spec
;
2003 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
2006 Append_To
(Spec_Decls
, Fin_Spec
);
2010 -- When the finalizer acts solely as a cleanup routine, the body
2011 -- is inserted right after the spec.
2013 if Acts_As_Clean
and not Has_Ctrl_Objs
then
2014 Insert_After
(Fin_Spec
, Fin_Body
);
2016 -- In all other cases the body is inserted after either:
2018 -- 1) The counter update statement of the last controlled object
2019 -- 2) The last top level nested controlled package
2020 -- 3) The last top level controlled instantiation
2023 -- Manually freeze the spec. This is somewhat of a hack because
2024 -- a subprogram is frozen when its body is seen and the freeze
2025 -- node appears right before the body. However, in this case,
2026 -- the spec must be frozen earlier since the At_End handler
2027 -- must be able to call it.
2030 -- procedure Fin_Id; -- Spec
2031 -- [Fin_Id] -- Freeze node
2035 -- Fin_Id; -- At_End handler
2038 Ensure_Freeze_Node
(Fin_Id
);
2039 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2040 Set_Is_Frozen
(Fin_Id
);
2042 -- In the case where the last construct to contain a controlled
2043 -- object is either a nested package, an instantiation or a
2044 -- freeze node, the body must be inserted directly after the
2045 -- construct, except if the insertion point is already placed
2046 -- after the construct, typically in the statement list.
2048 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2049 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2051 (List_Containing
(Last_Top_Level_Ctrl_Construct
) = Spec_Decls
2052 and then Present
(Stmts
)
2053 and then List_Containing
(Finalizer_Insert_Nod
) = Stmts
)
2055 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2058 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2061 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2064 -- Never consider that the finalizer procedure is enabled Ghost, even
2065 -- when the corresponding unit is Ghost, as this would lead to an
2066 -- an external name with a ___ghost_ prefix that the binder cannot
2067 -- generate, as it has no knowledge of the Ghost status of units.
2069 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2070 end Create_Finalizer
;
2072 ------------------------
2073 -- New_Finalizer_Name --
2074 ------------------------
2076 function New_Finalizer_Name
2077 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2079 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2080 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2081 -- has a non-standard scope, process the scope first.
2083 ------------------------
2084 -- New_Finalizer_Name --
2085 ------------------------
2087 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2089 if Scope
(Id
) = Standard_Standard
then
2090 Get_Name_String
(Chars
(Id
));
2093 New_Finalizer_Name
(Scope
(Id
));
2094 Add_Str_To_Name_Buffer
("__");
2095 Get_Name_String_And_Append
(Chars
(Id
));
2097 end New_Finalizer_Name
;
2099 -- Start of processing for New_Finalizer_Name
2102 -- Create the fully qualified name of the enclosing scope
2104 New_Finalizer_Name
(Spec_Id
);
2107 -- __finalize_[spec|body]
2109 Add_Str_To_Name_Buffer
("__finalize_");
2112 Add_Str_To_Name_Buffer
("spec");
2114 Add_Str_To_Name_Buffer
("body");
2118 end New_Finalizer_Name
;
2120 --------------------------
2121 -- Process_Declarations --
2122 --------------------------
2124 procedure Process_Declarations
2126 Preprocess
: Boolean := False;
2127 Top_Level
: Boolean := False)
2132 Obj_Typ
: Entity_Id
;
2133 Pack_Id
: Entity_Id
;
2137 Old_Counter_Val
: Nat
;
2138 -- This variable is used to determine whether a nested package or
2139 -- instance contains at least one controlled object.
2141 procedure Process_Package_Body
(Decl
: Node_Id
);
2142 -- Process an N_Package_Body node
2144 procedure Processing_Actions
2145 (Has_No_Init
: Boolean := False;
2146 Is_Protected
: Boolean := False);
2147 -- Depending on the mode of operation of Process_Declarations, either
2148 -- increment the controlled object counter, set the controlled object
2149 -- flag and store the last top level construct or process the current
2150 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2151 -- the current declaration may not have initialization proc(s). Flag
2152 -- Is_Protected should be set when the current declaration denotes a
2153 -- simple protected object.
2155 --------------------------
2156 -- Process_Package_Body --
2157 --------------------------
2159 procedure Process_Package_Body
(Decl
: Node_Id
) is
2161 -- Do not inspect an ignored Ghost package body because all
2162 -- code found within will not appear in the final tree.
2164 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2167 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
then
2168 Old_Counter_Val
:= Counter_Val
;
2169 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2171 -- The nested package body is the last construct to contain
2172 -- a controlled object.
2176 and then No
(Last_Top_Level_Ctrl_Construct
)
2177 and then Counter_Val
> Old_Counter_Val
2179 Last_Top_Level_Ctrl_Construct
:= Decl
;
2182 end Process_Package_Body
;
2184 ------------------------
2185 -- Processing_Actions --
2186 ------------------------
2188 procedure Processing_Actions
2189 (Has_No_Init
: Boolean := False;
2190 Is_Protected
: Boolean := False)
2193 -- Library-level tagged type
2195 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2197 Has_Tagged_Types
:= True;
2199 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2200 Last_Top_Level_Ctrl_Construct
:= Decl
;
2203 -- Unregister tagged type, unless No_Tagged_Type_Registration
2206 elsif not Restriction_Active
(No_Tagged_Type_Registration
) then
2207 Process_Tagged_Type_Declaration
(Decl
);
2210 -- Controlled object declaration
2214 Counter_Val
:= Counter_Val
+ 1;
2215 Has_Ctrl_Objs
:= True;
2217 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2218 Last_Top_Level_Ctrl_Construct
:= Decl
;
2222 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2225 end Processing_Actions
;
2227 -- Start of processing for Process_Declarations
2230 if Is_Empty_List
(Decls
) then
2234 -- Process all declarations in reverse order
2236 Decl
:= Last_Non_Pragma
(Decls
);
2237 while Present
(Decl
) loop
2238 -- Library-level tagged types
2240 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2241 Typ
:= Defining_Identifier
(Decl
);
2243 -- Ignored Ghost types do not need any cleanup actions because
2244 -- they will not appear in the final tree.
2246 if Is_Ignored_Ghost_Entity
(Typ
) then
2249 elsif Is_Tagged_Type
(Typ
)
2250 and then Is_Library_Level_Entity
(Typ
)
2251 and then Convention
(Typ
) = Convention_Ada
2252 and then Present
(Access_Disp_Table
(Typ
))
2253 and then not Is_Abstract_Type
(Typ
)
2254 and then not No_Run_Time_Mode
2255 and then not Restriction_Active
(No_Tagged_Type_Registration
)
2256 and then RTE_Available
(RE_Register_Tag
)
2261 -- Regular object declarations
2263 elsif Nkind
(Decl
) = N_Object_Declaration
then
2264 Obj_Id
:= Defining_Identifier
(Decl
);
2265 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2266 Expr
:= Expression
(Decl
);
2268 -- Bypass any form of processing for objects which have their
2269 -- finalization disabled. This applies only to objects at the
2272 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2275 -- Finalization of transient objects are treated separately in
2276 -- order to handle sensitive cases. These include:
2278 -- * Aggregate expansion
2279 -- * If, case, and expression with actions expansion
2280 -- * Transient scopes
2282 -- If one of those contexts has marked the transient object as
2283 -- ignored, do not generate finalization actions for it.
2285 elsif Is_Finalized_Transient
(Obj_Id
)
2286 or else Is_Ignored_Transient
(Obj_Id
)
2290 -- Ignored Ghost objects do not need any cleanup actions
2291 -- because they will not appear in the final tree.
2293 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2296 -- The object is of the form:
2297 -- Obj : [constant] Typ [:= Expr];
2299 -- Do not process the incomplete view of a deferred constant.
2300 -- Note that an object initialized by means of a BIP function
2301 -- call may appear as a deferred constant after expansion
2302 -- activities. These kinds of objects must be finalized.
2304 elsif not Is_Imported
(Obj_Id
)
2305 and then Needs_Finalization
(Obj_Typ
)
2306 and then not (Ekind
(Obj_Id
) = E_Constant
2307 and then not Has_Completion
(Obj_Id
)
2308 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2312 -- The object is of the form:
2313 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2315 -- Obj : Access_Typ :=
2316 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2318 elsif Is_Access_Type
(Obj_Typ
)
2319 and then Needs_Finalization
2320 (Available_View
(Designated_Type
(Obj_Typ
)))
2321 and then Present
(Expr
)
2323 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2325 (Is_Non_BIP_Func_Call
(Expr
)
2326 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2328 Processing_Actions
(Has_No_Init
=> True);
2330 -- Processing for "hook" objects generated for transient
2331 -- objects declared inside an Expression_With_Actions.
2333 elsif Is_Access_Type
(Obj_Typ
)
2334 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2335 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2336 N_Object_Declaration
2338 Processing_Actions
(Has_No_Init
=> True);
2340 -- Process intermediate results of an if expression with one
2341 -- of the alternatives using a controlled function call.
2343 elsif Is_Access_Type
(Obj_Typ
)
2344 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2345 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2346 N_Defining_Identifier
2347 and then Present
(Expr
)
2348 and then Nkind
(Expr
) = N_Null
2350 Processing_Actions
(Has_No_Init
=> True);
2352 -- Simple protected objects which use type System.Tasking.
2353 -- Protected_Objects.Protection to manage their locks should
2354 -- be treated as controlled since they require manual cleanup.
2355 -- The only exception is illustrated in the following example:
2358 -- type Ctrl is new Controlled ...
2359 -- procedure Finalize (Obj : in out Ctrl);
2363 -- package body Pkg is
2364 -- protected Prot is
2365 -- procedure Do_Something (Obj : in out Ctrl);
2368 -- protected body Prot is
2369 -- procedure Do_Something (Obj : in out Ctrl) is ...
2372 -- procedure Finalize (Obj : in out Ctrl) is
2374 -- Prot.Do_Something (Obj);
2378 -- Since for the most part entities in package bodies depend on
2379 -- those in package specs, Prot's lock should be cleaned up
2380 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2381 -- This act however attempts to invoke Do_Something and fails
2382 -- because the lock has disappeared.
2384 elsif Ekind
(Obj_Id
) = E_Variable
2385 and then not In_Library_Level_Package_Body
(Obj_Id
)
2386 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2387 or else Has_Simple_Protected_Object
(Obj_Typ
))
2389 Processing_Actions
(Is_Protected
=> True);
2392 -- Specific cases of object renamings
2394 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2395 Obj_Id
:= Defining_Identifier
(Decl
);
2396 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2398 -- Bypass any form of processing for objects which have their
2399 -- finalization disabled. This applies only to objects at the
2402 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2405 -- Ignored Ghost object renamings do not need any cleanup
2406 -- actions because they will not appear in the final tree.
2408 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2411 -- Return object of a build-in-place function. This case is
2412 -- recognized and marked by the expansion of an extended return
2413 -- statement (see Expand_N_Extended_Return_Statement).
2415 elsif Needs_Finalization
(Obj_Typ
)
2416 and then Is_Return_Object
(Obj_Id
)
2417 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2419 Processing_Actions
(Has_No_Init
=> True);
2422 -- Inspect the freeze node of an access-to-controlled type and
2423 -- look for a delayed finalization master. This case arises when
2424 -- the freeze actions are inserted at a later time than the
2425 -- expansion of the context. Since Build_Finalizer is never called
2426 -- on a single construct twice, the master will be ultimately
2427 -- left out and never finalized. This is also needed for freeze
2428 -- actions of designated types themselves, since in some cases the
2429 -- finalization master is associated with a designated type's
2430 -- freeze node rather than that of the access type (see handling
2431 -- for freeze actions in Build_Finalization_Master).
2433 elsif Nkind
(Decl
) = N_Freeze_Entity
2434 and then Present
(Actions
(Decl
))
2436 Typ
:= Entity
(Decl
);
2438 -- Freeze nodes for ignored Ghost types do not need cleanup
2439 -- actions because they will never appear in the final tree.
2441 if Is_Ignored_Ghost_Entity
(Typ
) then
2444 elsif (Is_Access_Object_Type
(Typ
)
2445 and then Needs_Finalization
2446 (Available_View
(Designated_Type
(Typ
))))
2447 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2449 Old_Counter_Val
:= Counter_Val
;
2451 -- Freeze nodes are considered to be identical to packages
2452 -- and blocks in terms of nesting. The difference is that
2453 -- a finalization master created inside the freeze node is
2454 -- at the same nesting level as the node itself.
2456 Process_Declarations
(Actions
(Decl
), Preprocess
);
2458 -- The freeze node contains a finalization master
2462 and then No
(Last_Top_Level_Ctrl_Construct
)
2463 and then Counter_Val
> Old_Counter_Val
2465 Last_Top_Level_Ctrl_Construct
:= Decl
;
2469 -- Nested package declarations, avoid generics
2471 elsif Nkind
(Decl
) = N_Package_Declaration
then
2472 Pack_Id
:= Defining_Entity
(Decl
);
2473 Spec
:= Specification
(Decl
);
2475 -- Do not inspect an ignored Ghost package because all code
2476 -- found within will not appear in the final tree.
2478 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2481 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2482 Old_Counter_Val
:= Counter_Val
;
2483 Process_Declarations
2484 (Private_Declarations
(Spec
), Preprocess
);
2485 Process_Declarations
2486 (Visible_Declarations
(Spec
), Preprocess
);
2488 -- Either the visible or the private declarations contain a
2489 -- controlled object. The nested package declaration is the
2490 -- last such construct.
2494 and then No
(Last_Top_Level_Ctrl_Construct
)
2495 and then Counter_Val
> Old_Counter_Val
2497 Last_Top_Level_Ctrl_Construct
:= Decl
;
2501 -- Call the xxx__finalize_body procedure of a library level
2502 -- package instantiation if the body contains finalization
2505 if Present
(Generic_Parent
(Spec
))
2506 and then Is_Library_Level_Entity
(Pack_Id
)
2507 and then Present
(Body_Entity
(Generic_Parent
(Spec
)))
2513 P
:= Parent
(Body_Entity
(Generic_Parent
(Spec
)));
2515 and then Nkind
(P
) /= N_Package_Body
2521 Old_Counter_Val
:= Counter_Val
;
2522 Process_Declarations
(Declarations
(P
), Preprocess
);
2524 -- Note that we are processing the generic body
2525 -- template and not the actually instantiation
2526 -- (which is generated too late for us to process
2527 -- it), so there is no need to update in particular
2528 -- Last_Top_Level_Ctrl_Construct here.
2530 if Counter_Val
> Old_Counter_Val
then
2531 Counter_Val
:= Old_Counter_Val
;
2532 Set_Has_Controlled_Component
(Pack_Id
);
2537 elsif Has_Controlled_Component
(Pack_Id
) then
2539 -- We import the xxx__finalize_body routine since the
2540 -- generic body will be instantiated later.
2543 Id
: constant Node_Id
:=
2544 Make_Defining_Identifier
(Loc
,
2545 New_Finalizer_Name
(Defining_Unit_Name
(Spec
),
2546 For_Spec
=> False));
2549 Set_Has_Qualified_Name
(Id
);
2550 Set_Has_Fully_Qualified_Name
(Id
);
2551 Set_Is_Imported
(Id
);
2552 Set_Has_Completion
(Id
);
2553 Set_Interface_Name
(Id
,
2554 Make_String_Literal
(Loc
,
2555 Strval
=> Get_Name_String
(Chars
(Id
))));
2557 Append_New_To
(Finalizer_Stmts
,
2558 Make_Subprogram_Declaration
(Loc
,
2559 Make_Procedure_Specification
(Loc
,
2560 Defining_Unit_Name
=> Id
)));
2561 Append_To
(Finalizer_Stmts
,
2562 Make_Procedure_Call_Statement
(Loc
,
2563 Name
=> New_Occurrence_Of
(Id
, Loc
)));
2568 -- Nested package bodies, avoid generics
2570 elsif Nkind
(Decl
) = N_Package_Body
then
2571 Process_Package_Body
(Decl
);
2573 elsif Nkind
(Decl
) = N_Package_Body_Stub
2574 and then Present
(Library_Unit
(Decl
))
2576 Process_Package_Body
(Proper_Body
(Unit
(Library_Unit
(Decl
))));
2578 -- Handle a rare case caused by a controlled transient object
2579 -- created as part of a record init proc. The variable is wrapped
2580 -- in a block, but the block is not associated with a transient
2583 elsif Nkind
(Decl
) = N_Block_Statement
2584 and then Inside_Init_Proc
2586 Old_Counter_Val
:= Counter_Val
;
2588 if Present
(Handled_Statement_Sequence
(Decl
)) then
2589 Process_Declarations
2590 (Statements
(Handled_Statement_Sequence
(Decl
)),
2594 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2596 -- Either the declaration or statement list of the block has a
2597 -- controlled object.
2601 and then No
(Last_Top_Level_Ctrl_Construct
)
2602 and then Counter_Val
> Old_Counter_Val
2604 Last_Top_Level_Ctrl_Construct
:= Decl
;
2607 -- Handle the case where the original context has been wrapped in
2608 -- a block to avoid interference between exception handlers and
2609 -- At_End handlers. Treat the block as transparent and process its
2612 elsif Nkind
(Decl
) = N_Block_Statement
2613 and then Is_Finalization_Wrapper
(Decl
)
2615 if Present
(Handled_Statement_Sequence
(Decl
)) then
2616 Process_Declarations
2617 (Statements
(Handled_Statement_Sequence
(Decl
)),
2621 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2624 Prev_Non_Pragma
(Decl
);
2626 end Process_Declarations
;
2628 --------------------------------
2629 -- Process_Object_Declaration --
2630 --------------------------------
2632 procedure Process_Object_Declaration
2634 Has_No_Init
: Boolean := False;
2635 Is_Protected
: Boolean := False)
2637 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2638 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2640 Init_Typ
: Entity_Id
;
2641 -- The initialization type of the related object declaration. Note
2642 -- that this is not necessarily the same type as Obj_Typ because of
2643 -- possible type derivations.
2645 Obj_Typ
: Entity_Id
;
2646 -- The type of the related object declaration
2648 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2649 -- Func_Id denotes a build-in-place function. Generate the following
2652 -- if BIPallocfrom > Secondary_Stack'Pos
2653 -- and then BIPfinalizationmaster /= null
2656 -- type Ptr_Typ is access Obj_Typ;
2657 -- for Ptr_Typ'Storage_Pool
2658 -- use Base_Pool (BIPfinalizationmaster);
2660 -- Free (Ptr_Typ (Temp));
2664 -- Obj_Typ is the type of the current object, Temp is the original
2665 -- allocation which Obj_Id renames.
2667 procedure Find_Last_Init
2668 (Last_Init
: out Node_Id
;
2669 Body_Insert
: out Node_Id
);
2670 -- Find the last initialization call related to object declaration
2671 -- Decl. Last_Init denotes the last initialization call which follows
2672 -- Decl. Body_Insert denotes a node where the finalizer body could be
2673 -- potentially inserted after (if blocks are involved).
2675 -----------------------------
2676 -- Build_BIP_Cleanup_Stmts --
2677 -----------------------------
2679 function Build_BIP_Cleanup_Stmts
2680 (Func_Id
: Entity_Id
) return Node_Id
2682 Decls
: constant List_Id
:= New_List
;
2683 Fin_Mas_Id
: constant Entity_Id
:=
2684 Build_In_Place_Formal
2685 (Func_Id
, BIP_Finalization_Master
);
2686 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2687 Temp_Id
: constant Entity_Id
:=
2688 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2692 Free_Stmt
: Node_Id
;
2693 Pool_Id
: Entity_Id
;
2694 Ptr_Typ
: Entity_Id
;
2698 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2700 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2703 Make_Object_Renaming_Declaration
(Loc
,
2704 Defining_Identifier
=> Pool_Id
,
2706 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2708 Make_Explicit_Dereference
(Loc
,
2710 Make_Function_Call
(Loc
,
2712 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2713 Parameter_Associations
=> New_List
(
2714 Make_Explicit_Dereference
(Loc
,
2716 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2718 -- Create an access type which uses the storage pool of the
2719 -- caller's finalization master.
2722 -- type Ptr_Typ is access Func_Typ;
2724 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2727 Make_Full_Type_Declaration
(Loc
,
2728 Defining_Identifier
=> Ptr_Typ
,
2730 Make_Access_To_Object_Definition
(Loc
,
2731 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2733 -- Perform minor decoration in order to set the master and the
2734 -- storage pool attributes.
2736 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2737 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2738 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2740 if Debug_Generated_Code
then
2741 Set_Debug_Info_Needed
(Pool_Id
);
2744 -- Create an explicit free statement. Note that the free uses the
2745 -- caller's pool expressed as a renaming.
2748 Make_Free_Statement
(Loc
,
2750 Unchecked_Convert_To
(Ptr_Typ
,
2751 New_Occurrence_Of
(Temp_Id
, Loc
)));
2753 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2755 -- Create a block to house the dummy type and the instantiation as
2756 -- well as to perform the cleanup the temporary.
2762 -- Free (Ptr_Typ (Temp_Id));
2766 Make_Block_Statement
(Loc
,
2767 Declarations
=> Decls
,
2768 Handled_Statement_Sequence
=>
2769 Make_Handled_Sequence_Of_Statements
(Loc
,
2770 Statements
=> New_List
(Free_Stmt
)));
2773 -- if BIPfinalizationmaster /= null then
2777 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2778 Right_Opnd
=> Make_Null
(Loc
));
2780 -- For unconstrained or tagged results, escalate the condition to
2781 -- include the allocation format. Generate:
2783 -- if BIPallocform > Secondary_Stack'Pos
2784 -- and then BIPfinalizationmaster /= null
2787 if Needs_BIP_Alloc_Form
(Func_Id
) then
2789 Alloc
: constant Entity_Id
:=
2790 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2796 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2798 Make_Integer_Literal
(Loc
,
2800 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2802 Right_Opnd
=> Cond
);
2812 Make_If_Statement
(Loc
,
2814 Then_Statements
=> New_List
(Free_Blk
));
2815 end Build_BIP_Cleanup_Stmts
;
2817 --------------------
2818 -- Find_Last_Init --
2819 --------------------
2821 procedure Find_Last_Init
2822 (Last_Init
: out Node_Id
;
2823 Body_Insert
: out Node_Id
)
2825 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2826 -- Find the last initialization call within the statements of
2829 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2830 -- Determine whether node N denotes one of the initialization
2831 -- procedures of types Init_Typ or Obj_Typ.
2833 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2834 -- Obtain the next statement which follows list member Stmt while
2835 -- ignoring artifacts related to access-before-elaboration checks.
2837 -----------------------------
2838 -- Find_Last_Init_In_Block --
2839 -----------------------------
2841 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2842 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2846 -- Examine the individual statements of the block in reverse to
2847 -- locate the last initialization call.
2849 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2850 Stmt
:= Last
(Statements
(HSS
));
2851 while Present
(Stmt
) loop
2853 -- Peek inside nested blocks in case aborts are allowed
2855 if Nkind
(Stmt
) = N_Block_Statement
then
2856 return Find_Last_Init_In_Block
(Stmt
);
2858 elsif Is_Init_Call
(Stmt
) then
2867 end Find_Last_Init_In_Block
;
2873 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2874 function Is_Init_Proc_Of
2875 (Subp_Id
: Entity_Id
;
2876 Typ
: Entity_Id
) return Boolean;
2877 -- Determine whether subprogram Subp_Id is a valid init proc of
2880 ---------------------
2881 -- Is_Init_Proc_Of --
2882 ---------------------
2884 function Is_Init_Proc_Of
2885 (Subp_Id
: Entity_Id
;
2886 Typ
: Entity_Id
) return Boolean
2888 Deep_Init
: Entity_Id
:= Empty
;
2889 Prim_Init
: Entity_Id
:= Empty
;
2890 Type_Init
: Entity_Id
:= Empty
;
2893 -- Obtain all possible initialization routines of the
2894 -- related type and try to match the subprogram entity
2895 -- against one of them.
2899 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2901 -- Primitive Initialize
2903 if Is_Controlled
(Typ
) then
2904 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2906 if Present
(Prim_Init
) then
2907 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2911 -- Type initialization routine
2913 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2914 Type_Init
:= Base_Init_Proc
(Typ
);
2918 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2920 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2922 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2923 end Is_Init_Proc_Of
;
2927 Call_Id
: Entity_Id
;
2929 -- Start of processing for Is_Init_Call
2932 if Nkind
(N
) = N_Procedure_Call_Statement
2933 and then Nkind
(Name
(N
)) = N_Identifier
2935 Call_Id
:= Entity
(Name
(N
));
2937 -- Consider both the type of the object declaration and its
2938 -- related initialization type.
2941 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2943 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2949 -----------------------------
2950 -- Next_Suitable_Statement --
2951 -----------------------------
2953 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2957 -- Skip call markers and Program_Error raises installed by the
2960 Result
:= Next
(Stmt
);
2961 while Present
(Result
) loop
2962 exit when Nkind
(Result
) not in
2963 N_Call_Marker | N_Raise_Program_Error
;
2969 end Next_Suitable_Statement
;
2977 Deep_Init_Found
: Boolean := False;
2978 -- A flag set when a call to [Deep_]Initialize has been found
2980 -- Start of processing for Find_Last_Init
2984 Body_Insert
:= Empty
;
2986 -- Object renamings and objects associated with controlled
2987 -- function results do not require initialization.
2993 Stmt
:= Next_Suitable_Statement
(Decl
);
2995 -- For an object with suppressed initialization, we check whether
2996 -- there is in fact no initialization expression. If there is not,
2997 -- then this is an object declaration that has been turned into a
2998 -- different object declaration that calls the build-in-place
2999 -- function in a 'Reference attribute, as in "F(...)'Reference".
3000 -- We search for that later object declaration, so that the
3001 -- Inc_Decl will be inserted after the call. Otherwise, if the
3002 -- call raises an exception, we will finalize the (uninitialized)
3003 -- object, which is wrong.
3005 if No_Initialization
(Decl
) then
3006 if No
(Expression
(Last_Init
)) then
3009 exit when No
(Last_Init
);
3010 exit when Nkind
(Last_Init
) = N_Object_Declaration
3011 and then Nkind
(Expression
(Last_Init
)) = N_Reference
3012 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
3014 and then Is_Expanded_Build_In_Place_Call
3015 (Prefix
(Expression
(Last_Init
)));
3021 -- If the initialization is in the declaration, we're done, so
3022 -- early return if we have no more statements or they have been
3023 -- rewritten, which means that they were in the source code.
3025 elsif No
(Stmt
) or else Original_Node
(Stmt
) /= Stmt
then
3028 -- In all other cases the initialization calls follow the related
3029 -- object. The general structure of object initialization built by
3030 -- routine Default_Initialize_Object is as follows:
3032 -- [begin -- aborts allowed
3034 -- Type_Init_Proc (Obj);
3035 -- [begin] -- exceptions allowed
3036 -- Deep_Initialize (Obj);
3037 -- [exception -- exceptions allowed
3039 -- Deep_Finalize (Obj, Self => False);
3042 -- [at end -- aborts allowed
3046 -- When aborts are allowed, the initialization calls are housed
3049 elsif Nkind
(Stmt
) = N_Block_Statement
then
3050 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
3051 Body_Insert
:= Stmt
;
3053 -- Otherwise the initialization calls follow the related object
3056 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
3058 -- Check for an optional call to Deep_Initialize which may
3059 -- appear within a block depending on whether the object has
3060 -- controlled components.
3062 if Present
(Stmt_2
) then
3063 if Nkind
(Stmt_2
) = N_Block_Statement
then
3064 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
3066 if Present
(Call
) then
3067 Deep_Init_Found
:= True;
3069 Body_Insert
:= Stmt_2
;
3072 elsif Is_Init_Call
(Stmt_2
) then
3073 Deep_Init_Found
:= True;
3074 Last_Init
:= Stmt_2
;
3075 Body_Insert
:= Last_Init
;
3079 -- If the object lacks a call to Deep_Initialize, then it must
3080 -- have a call to its related type init proc.
3082 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
3084 Body_Insert
:= Last_Init
;
3092 Count_Ins
: Node_Id
;
3094 Fin_Stmts
: List_Id
:= No_List
;
3097 Label_Id
: Entity_Id
;
3100 -- Start of processing for Process_Object_Declaration
3103 -- Handle the object type and the reference to the object
3105 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
3106 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
3109 if Is_Access_Type
(Obj_Typ
) then
3110 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
3111 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
3113 elsif Is_Concurrent_Type
(Obj_Typ
)
3114 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
3116 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
3117 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3119 elsif Is_Private_Type
(Obj_Typ
)
3120 and then Present
(Full_View
(Obj_Typ
))
3122 Obj_Typ
:= Full_View
(Obj_Typ
);
3123 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3125 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3126 Obj_Typ
:= Base_Type
(Obj_Typ
);
3127 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3134 Set_Etype
(Obj_Ref
, Obj_Typ
);
3136 -- Handle the initialization type of the object declaration
3138 Init_Typ
:= Obj_Typ
;
3140 if Is_Private_Type
(Init_Typ
)
3141 and then Present
(Full_View
(Init_Typ
))
3143 Init_Typ
:= Full_View
(Init_Typ
);
3145 elsif Is_Untagged_Derivation
(Init_Typ
) then
3146 Init_Typ
:= Root_Type
(Init_Typ
);
3153 -- Set a new value for the state counter and insert the statement
3154 -- after the object declaration. Generate:
3156 -- Counter := <value>;
3159 Make_Assignment_Statement
(Loc
,
3160 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3161 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3163 -- Insert the counter after all initialization has been done. The
3164 -- place of insertion depends on the context.
3166 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3168 -- The object is initialized by a build-in-place function call.
3169 -- The counter insertion point is after the function call.
3171 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3172 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3175 -- The object is initialized by an aggregate. Insert the counter
3176 -- after the last aggregate assignment.
3178 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3179 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3182 -- In all other cases the counter is inserted after the last call
3183 -- to either [Deep_]Initialize or the type-specific init proc.
3186 Find_Last_Init
(Count_Ins
, Body_Ins
);
3189 -- In all other cases the counter is inserted after the last call to
3190 -- either [Deep_]Initialize or the type-specific init proc.
3193 Find_Last_Init
(Count_Ins
, Body_Ins
);
3196 -- If the Initialize function is null or trivial, the call will have
3197 -- been replaced with a null statement, in which case place counter
3198 -- declaration after object declaration itself.
3200 if No
(Count_Ins
) then
3204 Insert_After
(Count_Ins
, Inc_Decl
);
3207 -- If the current declaration is the last in the list, the finalizer
3208 -- body needs to be inserted after the set counter statement for the
3209 -- current object declaration. This is complicated by the fact that
3210 -- the set counter statement may appear in abort deferred block. In
3211 -- that case, the proper insertion place is after the block.
3213 if No
(Finalizer_Insert_Nod
) then
3215 -- Insertion after an abort deferred block
3217 if Present
(Body_Ins
) then
3218 Finalizer_Insert_Nod
:= Body_Ins
;
3220 Finalizer_Insert_Nod
:= Inc_Decl
;
3224 -- Create the associated label with this object, generate:
3226 -- L<counter> : label;
3229 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3231 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3232 Label
:= Make_Label
(Loc
, Label_Id
);
3234 Prepend_To
(Finalizer_Decls
,
3235 Make_Implicit_Label_Declaration
(Loc
,
3236 Defining_Identifier
=> Entity
(Label_Id
),
3237 Label_Construct
=> Label
));
3239 -- Create the associated jump with this object, generate:
3241 -- when <counter> =>
3244 Prepend_To
(Jump_Alts
,
3245 Make_Case_Statement_Alternative
(Loc
,
3246 Discrete_Choices
=> New_List
(
3247 Make_Integer_Literal
(Loc
, Counter_Val
)),
3248 Statements
=> New_List
(
3249 Make_Goto_Statement
(Loc
,
3250 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3252 -- Insert the jump destination, generate:
3256 Append_To
(Finalizer_Stmts
, Label
);
3258 -- Disable warnings on Obj_Id. This works around an issue where GCC
3259 -- is not able to detect that Obj_Id is protected by a counter and
3260 -- emits spurious warnings.
3262 if not Comes_From_Source
(Obj_Id
) then
3263 Set_Warnings_Off
(Obj_Id
);
3266 -- Processing for simple protected objects. Such objects require
3267 -- manual finalization of their lock managers.
3269 if Is_Protected
then
3270 if Is_Simple_Protected_Type
(Obj_Typ
) then
3271 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3273 if Present
(Fin_Call
) then
3274 Fin_Stmts
:= New_List
(Fin_Call
);
3277 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3278 if Is_Record_Type
(Obj_Typ
) then
3279 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3280 elsif Is_Array_Type
(Obj_Typ
) then
3281 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3287 -- System.Tasking.Protected_Objects.Finalize_Protection
3295 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3296 Fin_Stmts
:= New_List
(
3297 Make_Block_Statement
(Loc
,
3298 Handled_Statement_Sequence
=>
3299 Make_Handled_Sequence_Of_Statements
(Loc
,
3300 Statements
=> Fin_Stmts
,
3302 Exception_Handlers
=> New_List
(
3303 Make_Exception_Handler
(Loc
,
3304 Exception_Choices
=> New_List
(
3305 Make_Others_Choice
(Loc
)),
3307 Statements
=> New_List
(
3308 Make_Null_Statement
(Loc
)))))));
3311 -- Processing for regular controlled objects
3316 -- [Deep_]Finalize (Obj);
3319 -- when Id : others =>
3320 -- if not Raised then
3322 -- Save_Occurrence (E, Id);
3331 -- Guard against a missing [Deep_]Finalize when the object type
3332 -- was not properly frozen.
3334 if No
(Fin_Call
) then
3335 Fin_Call
:= Make_Null_Statement
(Loc
);
3338 -- For CodePeer, the exception handlers normally generated here
3339 -- generate complex flowgraphs which result in capacity problems.
3340 -- Omitting these handlers for CodePeer is justified as follows:
3342 -- If a handler is dead, then omitting it is surely ok
3344 -- If a handler is live, then CodePeer should flag the
3345 -- potentially-exception-raising construct that causes it
3346 -- to be live. That is what we are interested in, not what
3347 -- happens after the exception is raised.
3349 if Exceptions_OK
and not CodePeer_Mode
then
3350 Fin_Stmts
:= New_List
(
3351 Make_Block_Statement
(Loc
,
3352 Handled_Statement_Sequence
=>
3353 Make_Handled_Sequence_Of_Statements
(Loc
,
3354 Statements
=> New_List
(Fin_Call
),
3356 Exception_Handlers
=> New_List
(
3357 Build_Exception_Handler
3358 (Finalizer_Data
, For_Package
)))));
3360 -- When exception handlers are prohibited, the finalization call
3361 -- appears unprotected. Any exception raised during finalization
3362 -- will bypass the circuitry which ensures the cleanup of all
3363 -- remaining objects.
3366 Fin_Stmts
:= New_List
(Fin_Call
);
3369 -- If we are dealing with a return object of a build-in-place
3370 -- function, generate the following cleanup statements:
3372 -- if BIPallocfrom > Secondary_Stack'Pos
3373 -- and then BIPfinalizationmaster /= null
3376 -- type Ptr_Typ is access Obj_Typ;
3377 -- for Ptr_Typ'Storage_Pool use
3378 -- Base_Pool (BIPfinalizationmaster.all).all;
3380 -- Free (Ptr_Typ (Temp));
3384 -- The generated code effectively detaches the temporary from the
3385 -- caller finalization master and deallocates the object.
3387 if Is_Return_Object
(Obj_Id
) then
3389 Func_Id
: constant Entity_Id
:=
3390 Return_Applies_To
(Scope
(Obj_Id
));
3393 if Is_Build_In_Place_Function
(Func_Id
)
3394 and then Needs_BIP_Finalization_Master
(Func_Id
)
3396 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3401 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3402 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3404 -- Temporaries created for the purpose of "exporting" a
3405 -- transient object out of an Expression_With_Actions (EWA)
3406 -- need guards. The following illustrates the usage of such
3409 -- Access_Typ : access [all] Obj_Typ;
3410 -- Temp : Access_Typ := null;
3411 -- <Counter> := ...;
3414 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3415 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3417 -- Temp := Ctrl_Trans'Unchecked_Access;
3420 -- The finalization machinery does not process EWA nodes as
3421 -- this may lead to premature finalization of expressions. Note
3422 -- that Temp is marked as being properly initialized regardless
3423 -- of whether the initialization of Ctrl_Trans succeeded. Since
3424 -- a failed initialization may leave Temp with a value of null,
3425 -- add a guard to handle this case:
3427 -- if Obj /= null then
3428 -- <object finalization statements>
3431 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3432 N_Object_Declaration
3434 Fin_Stmts
:= New_List
(
3435 Make_If_Statement
(Loc
,
3438 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3439 Right_Opnd
=> Make_Null
(Loc
)),
3440 Then_Statements
=> Fin_Stmts
));
3442 -- Return objects use a flag to aid in processing their
3443 -- potential finalization when the enclosing function fails
3444 -- to return properly. Generate:
3447 -- <object finalization statements>
3451 Fin_Stmts
:= New_List
(
3452 Make_If_Statement
(Loc
,
3457 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3459 Then_Statements
=> Fin_Stmts
));
3464 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3466 -- Since the declarations are examined in reverse, the state counter
3467 -- must be decremented in order to keep with the true position of
3470 Counter_Val
:= Counter_Val
- 1;
3471 end Process_Object_Declaration
;
3473 -------------------------------------
3474 -- Process_Tagged_Type_Declaration --
3475 -------------------------------------
3477 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3478 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3479 DT_Ptr
: constant Entity_Id
:=
3480 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3483 -- Ada.Tags.Unregister_Tag (<Typ>P);
3485 Append_To
(Tagged_Type_Stmts
,
3486 Make_Procedure_Call_Statement
(Loc
,
3488 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3489 Parameter_Associations
=> New_List
(
3490 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3491 end Process_Tagged_Type_Declaration
;
3493 -- Start of processing for Build_Finalizer
3498 -- Do not perform this expansion in SPARK mode because it is not
3501 if GNATprove_Mode
then
3505 -- Step 1: Extract all lists which may contain controlled objects or
3506 -- library-level tagged types.
3508 if For_Package_Spec
then
3509 Decls
:= Visible_Declarations
(Specification
(N
));
3510 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3512 -- Retrieve the package spec id
3514 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3516 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3517 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3520 -- Accept statement, block, entry body, package body, protected body,
3521 -- subprogram body or task body.
3524 Decls
:= Declarations
(N
);
3525 HSS
:= Handled_Statement_Sequence
(N
);
3527 if Present
(HSS
) then
3528 if Present
(Statements
(HSS
)) then
3529 Stmts
:= Statements
(HSS
);
3532 if Present
(At_End_Proc
(HSS
)) then
3533 Prev_At_End
:= At_End_Proc
(HSS
);
3537 -- Retrieve the package spec id for package bodies
3539 if For_Package_Body
then
3540 Spec_Id
:= Corresponding_Spec
(N
);
3544 -- Do not process nested packages since those are handled by the
3545 -- enclosing scope's finalizer. Do not process non-expanded package
3546 -- instantiations since those will be re-analyzed and re-expanded.
3550 (not Is_Library_Level_Entity
(Spec_Id
)
3552 -- Nested packages are library-level entities, but do not need to
3553 -- be processed separately.
3555 or else Scope_Depth
(Spec_Id
) /= Uint_1
3557 -- Do not build two finalizers for an instance without body that
3558 -- is a library unit (see Analyze_Package_Instantiation).
3560 or else (Is_Generic_Instance
(Spec_Id
)
3561 and then Package_Instantiation
(Spec_Id
) = N
))
3563 -- Still need to process library-level package body instances, whose
3564 -- instantiation was deferred and thus could not be seen during the
3565 -- processing of the enclosing scope, and which may contain objects
3566 -- requiring finalization.
3570 and then Is_Library_Level_Entity
(Spec_Id
)
3571 and then Is_Generic_Instance
(Spec_Id
))
3576 -- Step 2: Object [pre]processing
3580 -- Preprocess the visible declarations now in order to obtain the
3581 -- correct number of controlled object by the time the private
3582 -- declarations are processed.
3584 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3586 -- From all the possible contexts, only package specifications may
3587 -- have private declarations.
3589 if For_Package_Spec
then
3590 Process_Declarations
3591 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3594 -- The current context may lack controlled objects, but require some
3595 -- other form of completion (task termination for instance). In such
3596 -- cases, the finalizer must be created and carry the additional
3599 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3603 -- The preprocessing has determined that the context has controlled
3604 -- objects or library-level tagged types.
3606 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3608 -- Private declarations are processed first in order to preserve
3609 -- possible dependencies between public and private objects.
3611 if For_Package_Spec
then
3612 Process_Declarations
(Priv_Decls
);
3615 Process_Declarations
(Decls
);
3621 -- Preprocess both declarations and statements
3623 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3624 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3626 -- At this point it is known that N has controlled objects. Ensure
3627 -- that N has a declarative list since the finalizer spec will be
3630 if Has_Ctrl_Objs
and then No
(Decls
) then
3631 Set_Declarations
(N
, New_List
);
3632 Decls
:= Declarations
(N
);
3633 Spec_Decls
:= Decls
;
3636 -- The current context may lack controlled objects, but require some
3637 -- other form of completion (task termination for instance). In such
3638 -- cases, the finalizer must be created and carry the additional
3641 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3645 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3646 Process_Declarations
(Stmts
);
3647 Process_Declarations
(Decls
);
3651 -- Step 3: Finalizer creation
3653 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3656 end Build_Finalizer
;
3658 --------------------------
3659 -- Build_Finalizer_Call --
3660 --------------------------
3662 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3664 -- Do not perform this expansion in SPARK mode because we do not create
3665 -- finalizers in the first place.
3667 if GNATprove_Mode
then
3671 -- If the construct to be cleaned up is a protected subprogram body, the
3672 -- finalizer call needs to be associated with the block that wraps the
3673 -- unprotected version of the subprogram. The following illustrates this
3676 -- procedure Prot_SubpP is
3677 -- procedure finalizer is
3679 -- Service_Entries (Prot_Obj);
3686 -- Prot_SubpN (Prot_Obj);
3693 Loc
: constant Source_Ptr
:= Sloc
(N
);
3695 Is_Protected_Subp_Body
: constant Boolean :=
3696 Nkind
(N
) = N_Subprogram_Body
3697 and then Is_Protected_Subprogram_Body
(N
);
3698 -- True if N is the protected version of a subprogram that belongs to
3699 -- a protected type.
3701 HSS
: constant Node_Id
:=
3702 (if Is_Protected_Subp_Body
3703 then Handled_Statement_Sequence
3704 (Last
(Statements
(Handled_Statement_Sequence
(N
))))
3705 else Handled_Statement_Sequence
(N
));
3707 -- We attach the At_End_Proc to the HSS if this is an accept
3708 -- statement or extended return statement. Also in the case of
3709 -- a protected subprogram, because if Service_Entries raises an
3710 -- exception, we do not lock the PO, so we also do not want to
3713 Use_HSS
: constant Boolean :=
3714 Nkind
(N
) in N_Accept_Statement | N_Extended_Return_Statement
3715 or else Is_Protected_Subp_Body
;
3717 At_End_Proc_Bearer
: constant Node_Id
:= (if Use_HSS
then HSS
else N
);
3719 pragma Assert
(No
(At_End_Proc
(At_End_Proc_Bearer
)));
3720 Set_At_End_Proc
(At_End_Proc_Bearer
, New_Occurrence_Of
(Fin_Id
, Loc
));
3721 -- Attach reference to finalizer to tree, for LLVM use
3722 Set_Parent
(At_End_Proc
(At_End_Proc_Bearer
), At_End_Proc_Bearer
);
3723 Analyze
(At_End_Proc
(At_End_Proc_Bearer
));
3724 Expand_At_End_Handler
(At_End_Proc_Bearer
, Empty
);
3726 end Build_Finalizer_Call
;
3728 ---------------------
3729 -- Build_Late_Proc --
3730 ---------------------
3732 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3734 for Final_Prim
in Name_Of
'Range loop
3735 if Name_Of
(Final_Prim
) = Nam
then
3738 (Prim
=> Final_Prim
,
3740 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3743 end Build_Late_Proc
;
3745 -------------------------------
3746 -- Build_Object_Declarations --
3747 -------------------------------
3749 procedure Build_Object_Declarations
3750 (Data
: out Finalization_Exception_Data
;
3753 For_Package
: Boolean := False)
3758 -- This variable captures an unused dummy internal entity, see the
3759 -- comment associated with its use.
3762 pragma Assert
(Decls
/= No_List
);
3764 -- Always set the proper location as it may be needed even when
3765 -- exception propagation is forbidden.
3769 if Restriction_Active
(No_Exception_Propagation
) then
3770 Data
.Abort_Id
:= Empty
;
3772 Data
.Raised_Id
:= Empty
;
3776 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3778 -- In certain scenarios, finalization can be triggered by an abort. If
3779 -- the finalization itself fails and raises an exception, the resulting
3780 -- Program_Error must be supressed and replaced by an abort signal. In
3781 -- order to detect this scenario, save the state of entry into the
3782 -- finalization code.
3784 -- This is not needed for library-level finalizers as they are called by
3785 -- the environment task and cannot be aborted.
3787 if not For_Package
then
3788 if Abort_Allowed
then
3789 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3792 -- Abort_Id : constant Boolean := <A_Expr>;
3795 Make_Object_Declaration
(Loc
,
3796 Defining_Identifier
=> Data
.Abort_Id
,
3797 Constant_Present
=> True,
3798 Object_Definition
=>
3799 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3801 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3803 -- Abort is not required
3806 -- Generate a dummy entity to ensure that the internal symbols are
3807 -- in sync when a unit is compiled with and without aborts.
3809 Dummy
:= Make_Temporary
(Loc
, 'A');
3810 Data
.Abort_Id
:= Empty
;
3813 -- Library-level finalizers
3816 Data
.Abort_Id
:= Empty
;
3819 if Exception_Extra_Info
then
3820 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3823 -- E_Id : Exception_Occurrence;
3826 Make_Object_Declaration
(Loc
,
3827 Defining_Identifier
=> Data
.E_Id
,
3828 Object_Definition
=>
3829 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3830 Set_No_Initialization
(Decl
);
3832 Append_To
(Decls
, Decl
);
3839 -- Raised_Id : Boolean := False;
3842 Make_Object_Declaration
(Loc
,
3843 Defining_Identifier
=> Data
.Raised_Id
,
3844 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3845 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3847 if Debug_Generated_Code
then
3848 Set_Debug_Info_Needed
(Data
.Raised_Id
);
3850 end Build_Object_Declarations
;
3852 ---------------------------
3853 -- Build_Raise_Statement --
3854 ---------------------------
3856 function Build_Raise_Statement
3857 (Data
: Finalization_Exception_Data
) return Node_Id
3863 -- Standard run-time use the specialized routine
3864 -- Raise_From_Controlled_Operation.
3866 if Exception_Extra_Info
3867 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3870 Make_Procedure_Call_Statement
(Data
.Loc
,
3873 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3874 Parameter_Associations
=>
3875 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3877 -- Restricted run-time: exception messages are not supported and hence
3878 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3883 Make_Raise_Program_Error
(Data
.Loc
,
3884 Reason
=> PE_Finalize_Raised_Exception
);
3889 -- Raised_Id and then not Abort_Id
3893 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3895 if Present
(Data
.Abort_Id
) then
3896 Expr
:= Make_And_Then
(Data
.Loc
,
3899 Make_Op_Not
(Data
.Loc
,
3900 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3905 -- if Raised_Id and then not Abort_Id then
3906 -- Raise_From_Controlled_Operation (E_Id);
3908 -- raise Program_Error; -- restricted runtime
3912 Make_If_Statement
(Data
.Loc
,
3914 Then_Statements
=> New_List
(Stmt
));
3915 end Build_Raise_Statement
;
3917 -----------------------------
3918 -- Build_Record_Deep_Procs --
3919 -----------------------------
3921 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3925 (Prim
=> Initialize_Case
,
3927 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3929 if not Is_Limited_View
(Typ
) then
3932 (Prim
=> Adjust_Case
,
3934 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3937 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3938 -- suppressed since these routine will not be used.
3940 if not Restriction_Active
(No_Finalization
) then
3943 (Prim
=> Finalize_Case
,
3945 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3947 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3949 if not CodePeer_Mode
then
3952 (Prim
=> Address_Case
,
3954 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3957 end Build_Record_Deep_Procs
;
3963 function Cleanup_Array
3966 Typ
: Entity_Id
) return List_Id
3968 Loc
: constant Source_Ptr
:= Sloc
(N
);
3969 Index_List
: constant List_Id
:= New_List
;
3971 function Free_Component
return List_Id
;
3972 -- Generate the code to finalize the task or protected subcomponents
3973 -- of a single component of the array.
3975 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3976 -- Generate a loop over one dimension of the array
3978 --------------------
3979 -- Free_Component --
3980 --------------------
3982 function Free_Component
return List_Id
is
3983 Stmts
: List_Id
:= New_List
;
3985 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3988 -- Component type is known to contain tasks or protected objects
3991 Make_Indexed_Component
(Loc
,
3992 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3993 Expressions
=> Index_List
);
3995 Set_Etype
(Tsk
, C_Typ
);
3997 if Is_Task_Type
(C_Typ
) then
3998 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4000 elsif Is_Simple_Protected_Type
(C_Typ
) then
4001 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4003 elsif Is_Record_Type
(C_Typ
) then
4004 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
4006 elsif Is_Array_Type
(C_Typ
) then
4007 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
4013 ------------------------
4014 -- Free_One_Dimension --
4015 ------------------------
4017 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
4021 if Dim
> Number_Dimensions
(Typ
) then
4022 return Free_Component
;
4024 -- Here we generate the required loop
4027 Index
:= Make_Temporary
(Loc
, 'J');
4028 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
4031 Make_Implicit_Loop_Statement
(N
,
4032 Identifier
=> Empty
,
4034 Make_Iteration_Scheme
(Loc
,
4035 Loop_Parameter_Specification
=>
4036 Make_Loop_Parameter_Specification
(Loc
,
4037 Defining_Identifier
=> Index
,
4038 Discrete_Subtype_Definition
=>
4039 Make_Attribute_Reference
(Loc
,
4040 Prefix
=> Duplicate_Subexpr
(Obj
),
4041 Attribute_Name
=> Name_Range
,
4042 Expressions
=> New_List
(
4043 Make_Integer_Literal
(Loc
, Dim
))))),
4044 Statements
=> Free_One_Dimension
(Dim
+ 1)));
4046 end Free_One_Dimension
;
4048 -- Start of processing for Cleanup_Array
4051 return Free_One_Dimension
(1);
4054 --------------------
4055 -- Cleanup_Record --
4056 --------------------
4058 function Cleanup_Record
4061 Typ
: Entity_Id
) return List_Id
4063 Loc
: constant Source_Ptr
:= Sloc
(N
);
4064 Stmts
: constant List_Id
:= New_List
;
4065 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
4071 if Has_Discriminants
(U_Typ
)
4072 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
4073 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
4076 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
4078 -- For now, do not attempt to free a component that may appear in a
4079 -- variant, and instead issue a warning. Doing this "properly" would
4080 -- require building a case statement and would be quite a mess. Note
4081 -- that the RM only requires that free "work" for the case of a task
4082 -- access value, so already we go way beyond this in that we deal
4083 -- with the array case and non-discriminated record cases.
4086 ("task/protected object in variant record will not be freed??", N
);
4087 return New_List
(Make_Null_Statement
(Loc
));
4090 Comp
:= First_Component
(U_Typ
);
4091 while Present
(Comp
) loop
4092 if Chars
(Comp
) /= Name_uParent
4093 and then (Has_Task
(Etype
(Comp
))
4094 or else Has_Simple_Protected_Object
(Etype
(Comp
)))
4097 Make_Selected_Component
(Loc
,
4098 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
4099 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
4100 Set_Etype
(Tsk
, Etype
(Comp
));
4102 if Is_Task_Type
(Etype
(Comp
)) then
4103 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4105 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
4106 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4108 elsif Is_Record_Type
(Etype
(Comp
)) then
4110 -- Recurse, by generating the prefix of the argument to the
4111 -- eventual cleanup call.
4113 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
4115 elsif Is_Array_Type
(Etype
(Comp
)) then
4116 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
4120 Next_Component
(Comp
);
4126 ------------------------------
4127 -- Cleanup_Protected_Object --
4128 ------------------------------
4130 function Cleanup_Protected_Object
4132 Ref
: Node_Id
) return Node_Id
4134 Loc
: constant Source_Ptr
:= Sloc
(N
);
4137 -- For restricted run-time libraries (Ravenscar), tasks are
4138 -- non-terminating, and protected objects can only appear at library
4139 -- level, so we do not want finalization of protected objects.
4141 if Restricted_Profile
then
4146 Make_Procedure_Call_Statement
(Loc
,
4148 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4149 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4151 end Cleanup_Protected_Object
;
4157 function Cleanup_Task
4159 Ref
: Node_Id
) return Node_Id
4161 Loc
: constant Source_Ptr
:= Sloc
(N
);
4164 -- For restricted run-time libraries (Ravenscar), tasks are
4165 -- non-terminating and they can only appear at library level,
4166 -- so we do not want finalization of task objects.
4168 if Restricted_Profile
then
4173 Make_Procedure_Call_Statement
(Loc
,
4175 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4176 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4180 --------------------------------------
4181 -- Check_Unnesting_Elaboration_Code --
4182 --------------------------------------
4184 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4185 Loc
: constant Source_Ptr
:= Sloc
(N
);
4186 Block_Elab_Proc
: Entity_Id
:= Empty
;
4188 procedure Set_Block_Elab_Proc
;
4189 -- Create a defining identifier for a procedure that will replace
4190 -- a block with nested subprograms (unless it has already been created,
4191 -- in which case this is a no-op).
4193 procedure Set_Block_Elab_Proc
is
4195 if No
(Block_Elab_Proc
) then
4196 Block_Elab_Proc
:= Make_Temporary
(Loc
, 'I');
4198 end Set_Block_Elab_Proc
;
4200 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4201 -- Find entities in the elaboration code of a library package body that
4202 -- contain or represent a subprogram body. A body can appear within a
4203 -- block or a loop or can appear by itself if generated for an object
4204 -- declaration that involves controlled actions. The first such entity
4205 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4206 -- that will be used to reset the scopes of all entities that become
4207 -- local to the new elaboration procedure. This is needed for subsequent
4208 -- unnesting actions, which depend on proper setting of the Scope links
4209 -- to determine the nesting level of each subprogram.
4211 -----------------------
4212 -- Find_Local_Scope --
4213 -----------------------
4215 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4222 while Present
(Stat
) loop
4223 case Nkind
(Stat
) is
4224 when N_Block_Statement
=>
4225 if Present
(Identifier
(Stat
)) then
4226 Id
:= Entity
(Identifier
(Stat
));
4228 -- The Scope of this block needs to be reset to the new
4229 -- procedure if the block contains nested subprograms.
4231 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4232 Set_Block_Elab_Proc
;
4233 Set_Scope
(Id
, Block_Elab_Proc
);
4237 when N_Loop_Statement
=>
4238 Id
:= Entity
(Identifier
(Stat
));
4240 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4241 if Scope
(Id
) = Current_Scope
then
4242 Set_Block_Elab_Proc
;
4243 Set_Scope
(Id
, Block_Elab_Proc
);
4247 -- We traverse the loop's statements as well, which may
4248 -- include other block (etc.) statements that need to have
4249 -- their Scope set to Block_Elab_Proc. (Is this really the
4250 -- case, or do such nested blocks refer to the loop scope
4251 -- rather than the loop's enclosing scope???.)
4253 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4255 when N_If_Statement
=>
4256 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4257 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4259 Node
:= First
(Elsif_Parts
(Stat
));
4260 while Present
(Node
) loop
4261 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4265 when N_Case_Statement
=>
4266 Node
:= First
(Alternatives
(Stat
));
4267 while Present
(Node
) loop
4268 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4272 -- Reset the Scope of a subprogram occurring at the top level
4274 when N_Subprogram_Body
=>
4275 Id
:= Defining_Entity
(Stat
);
4277 Set_Block_Elab_Proc
;
4278 Set_Scope
(Id
, Block_Elab_Proc
);
4286 end Reset_Scopes_To_Block_Elab_Proc
;
4290 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4291 Elab_Body
: Node_Id
;
4292 Elab_Call
: Node_Id
;
4294 -- Start of processing for Check_Unnesting_Elaboration_Code
4297 if Present
(H_Seq
) then
4298 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4300 -- There may be subprograms declared in the exception handlers
4301 -- of the current body.
4303 if Present
(Exception_Handlers
(H_Seq
)) then
4305 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4307 while Present
(Handler
) loop
4308 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4315 if Present
(Block_Elab_Proc
) then
4317 Make_Subprogram_Body
(Loc
,
4319 Make_Procedure_Specification
(Loc
,
4320 Defining_Unit_Name
=> Block_Elab_Proc
),
4321 Declarations
=> New_List
,
4322 Handled_Statement_Sequence
=>
4323 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4326 Make_Procedure_Call_Statement
(Loc
,
4327 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4329 Append_To
(Declarations
(N
), Elab_Body
);
4330 Analyze
(Elab_Body
);
4331 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4333 Set_Handled_Statement_Sequence
(N
,
4334 Make_Handled_Sequence_Of_Statements
(Loc
,
4335 Statements
=> New_List
(Elab_Call
)));
4337 Analyze
(Elab_Call
);
4339 -- Could we reset the scopes of entities associated with the new
4340 -- procedure here via a loop over entities rather than doing it in
4341 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4344 end Check_Unnesting_Elaboration_Code
;
4346 ---------------------------------------
4347 -- Check_Unnesting_In_Decls_Or_Stmts --
4348 ---------------------------------------
4350 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4351 Decl_Or_Stmt
: Node_Id
;
4354 if Unnest_Subprogram_Mode
4355 and then Present
(Decls_Or_Stmts
)
4357 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4358 while Present
(Decl_Or_Stmt
) loop
4359 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4360 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4362 Unnest_Block
(Decl_Or_Stmt
);
4364 -- If-statements may contain subprogram bodies at the outer level
4365 -- of their statement lists, and the subprograms may make up-level
4366 -- references (such as to objects declared in the same statement
4367 -- list). Unlike block and loop cases, however, we don't have an
4368 -- entity on which to test the Contains_Subprogram flag, so
4369 -- Unnest_If_Statement must traverse the statement lists to
4370 -- determine whether there are nested subprograms present.
4372 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4373 Unnest_If_Statement
(Decl_Or_Stmt
);
4375 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4377 Id
: constant Entity_Id
:=
4378 Entity
(Identifier
(Decl_Or_Stmt
));
4381 -- When a top-level loop within declarations of a library
4382 -- package spec or body contains nested subprograms, we wrap
4383 -- it in a procedure to handle possible up-level references
4384 -- to entities associated with the loop (such as loop
4387 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4388 Unnest_Loop
(Decl_Or_Stmt
);
4392 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4393 and then not Modify_Tree_For_C
4395 Check_Unnesting_In_Decls_Or_Stmts
4396 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4397 Check_Unnesting_In_Decls_Or_Stmts
4398 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4400 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4401 and then not Modify_Tree_For_C
4403 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4404 if Present
(Statements
4405 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4407 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4408 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4409 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4413 Next
(Decl_Or_Stmt
);
4416 end Check_Unnesting_In_Decls_Or_Stmts
;
4418 ---------------------------------
4419 -- Check_Unnesting_In_Handlers --
4420 ---------------------------------
4422 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4423 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4426 if Present
(Stmt_Seq
)
4427 and then Present
(Exception_Handlers
(Stmt_Seq
))
4430 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4432 while Present
(Handler
) loop
4433 if Present
(Statements
(Handler
)) then
4434 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4441 end Check_Unnesting_In_Handlers
;
4443 ------------------------------
4444 -- Check_Visibly_Controlled --
4445 ------------------------------
4447 procedure Check_Visibly_Controlled
4448 (Prim
: Final_Primitives
;
4450 E
: in out Entity_Id
;
4451 Cref
: in out Node_Id
)
4453 Parent_Type
: Entity_Id
;
4457 if Is_Derived_Type
(Typ
)
4458 and then Comes_From_Source
(E
)
4459 and then No
(Overridden_Operation
(E
))
4461 -- We know that the explicit operation on the type does not override
4462 -- the inherited operation of the parent, and that the derivation
4463 -- is from a private type that is not visibly controlled.
4465 Parent_Type
:= Etype
(Typ
);
4466 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4468 if Present
(Op
) then
4471 -- Wrap the object to be initialized into the proper
4472 -- unchecked conversion, to be compatible with the operation
4475 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4476 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4478 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4482 end Check_Visibly_Controlled
;
4484 --------------------------
4485 -- Contains_Subprogram --
4486 --------------------------
4488 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4492 E
:= First_Entity
(Blk
);
4494 while Present
(E
) loop
4495 if Is_Subprogram
(E
) then
4498 elsif Ekind
(E
) in E_Block | E_Loop
4499 and then Contains_Subprogram
(E
)
4508 end Contains_Subprogram
;
4514 function Convert_View
4517 Ind
: Pos
:= 1) return Node_Id
4519 Fent
: Entity_Id
:= First_Entity
(Proc
);
4524 for J
in 2 .. Ind
loop
4528 Ftyp
:= Etype
(Fent
);
4530 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
4531 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4533 Atyp
:= Etype
(Arg
);
4536 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4537 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4540 and then Present
(Atyp
)
4541 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
4542 and then Base_Type
(Underlying_Type
(Atyp
)) =
4543 Base_Type
(Underlying_Type
(Ftyp
))
4545 return Unchecked_Convert_To
(Ftyp
, Arg
);
4547 -- If the argument is already a conversion, as generated by
4548 -- Make_Init_Call, set the target type to the type of the formal
4549 -- directly, to avoid spurious typing problems.
4551 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
4552 and then not Is_Class_Wide_Type
(Atyp
)
4554 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4555 Set_Etype
(Arg
, Ftyp
);
4558 -- Otherwise, introduce a conversion when the designated object
4559 -- has a type derived from the formal of the controlled routine.
4561 elsif Is_Private_Type
(Ftyp
)
4562 and then Present
(Atyp
)
4563 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4565 return Unchecked_Convert_To
(Ftyp
, Arg
);
4572 -------------------------------
4573 -- Establish_Transient_Scope --
4574 -------------------------------
4576 -- This procedure is called each time a transient block has to be inserted
4577 -- that is to say for each call to a function with unconstrained or tagged
4578 -- result. It creates a new scope on the scope stack in order to enclose
4579 -- all transient variables generated.
4581 procedure Establish_Transient_Scope
4583 Manage_Sec_Stack
: Boolean)
4585 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4586 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4588 function Find_Enclosing_Transient_Scope
return Entity_Id
;
4589 -- Examine the scope stack looking for the nearest enclosing transient
4590 -- scope within the innermost enclosing package or subprogram. Return
4591 -- Empty if no such scope exists.
4593 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
4594 -- Locate a suitable context for arbitrary node N which may need to be
4595 -- serviced by a transient scope. Return Empty if no suitable context
4598 procedure Delegate_Sec_Stack_Management
;
4599 -- Move the management of the secondary stack to the nearest enclosing
4602 procedure Create_Transient_Scope
(Context
: Node_Id
);
4603 -- Place a new scope on the scope stack in order to service construct
4604 -- Context. Context is the node found by Find_Transient_Context. The
4605 -- new scope may also manage the secondary stack.
4607 ----------------------------
4608 -- Create_Transient_Scope --
4609 ----------------------------
4611 procedure Create_Transient_Scope
(Context
: Node_Id
) is
4612 Loc
: constant Source_Ptr
:= Sloc
(N
);
4614 Iter_Loop
: Entity_Id
;
4615 Trans_Scop
: constant Entity_Id
:=
4616 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4619 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4621 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4624 Push_Scope
(Trans_Scop
);
4625 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
4626 Set_Scope_Is_Transient
;
4628 -- The transient scope must also manage the secondary stack
4630 if Manage_Sec_Stack
then
4631 Set_Uses_Sec_Stack
(Trans_Scop
);
4632 Check_Restriction
(No_Secondary_Stack
, N
);
4634 -- The expansion of iterator loops generates references to objects
4635 -- in order to extract elements from a container:
4637 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4638 -- Obj : <object type> renames Ref.all.Element.all;
4640 -- These references are controlled and returned on the secondary
4641 -- stack. A new reference is created at each iteration of the loop
4642 -- and as a result it must be finalized and the space occupied by
4643 -- it on the secondary stack reclaimed at the end of the current
4646 -- When the context that requires a transient scope is a call to
4647 -- routine Reference, the node to be wrapped is the source object:
4649 -- for Obj of Container loop
4651 -- Routine Wrap_Transient_Declaration however does not generate
4652 -- a physical block as wrapping a declaration will kill it too
4653 -- early. To handle this peculiar case, mark the related iterator
4654 -- loop as requiring the secondary stack. This signals the
4655 -- finalization machinery to manage the secondary stack (see
4656 -- routine Process_Statements_For_Controlled_Objects).
4658 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4660 if Present
(Iter_Loop
) then
4661 Set_Uses_Sec_Stack
(Iter_Loop
);
4665 if Debug_Flag_W
then
4666 Write_Str
(" <Transient>");
4669 end Create_Transient_Scope
;
4671 -----------------------------------
4672 -- Delegate_Sec_Stack_Management --
4673 -----------------------------------
4675 procedure Delegate_Sec_Stack_Management
is
4677 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4679 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4681 -- Prevent the search from going too far or within the scope
4682 -- space of another unit.
4684 if Scope
.Entity
= Standard_Standard
then
4687 -- No transient scope should be encountered during the
4688 -- traversal because Establish_Transient_Scope should have
4689 -- already handled this case.
4691 elsif Scope
.Is_Transient
then
4692 raise Program_Error
;
4694 -- The construct that requires secondary stack management is
4695 -- always enclosed by a package or subprogram scope.
4697 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
4698 Set_Uses_Sec_Stack
(Scope
.Entity
);
4699 Check_Restriction
(No_Secondary_Stack
, N
);
4706 -- At this point no suitable scope was found. This should never occur
4707 -- because a construct is always enclosed by a compilation unit which
4710 pragma Assert
(False);
4711 end Delegate_Sec_Stack_Management
;
4713 ------------------------------------
4714 -- Find_Enclosing_Transient_Scope --
4715 ------------------------------------
4717 function Find_Enclosing_Transient_Scope
return Entity_Id
is
4719 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4721 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4723 -- Prevent the search from going too far or within the scope
4724 -- space of another unit.
4726 if Scope
.Entity
= Standard_Standard
4727 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
4731 elsif Scope
.Is_Transient
then
4732 return Scope
.Entity
;
4738 end Find_Enclosing_Transient_Scope
;
4740 ----------------------------
4741 -- Find_Transient_Context --
4742 ----------------------------
4744 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
4745 Curr
: Node_Id
:= N
;
4746 Prev
: Node_Id
:= Empty
;
4749 while Present
(Curr
) loop
4750 case Nkind
(Curr
) is
4754 -- Declarations act as a boundary for a transient scope even if
4755 -- they are not wrapped, see Wrap_Transient_Declaration.
4757 when N_Object_Declaration
4758 | N_Object_Renaming_Declaration
4759 | N_Subtype_Declaration
4765 -- Statements and statement-like constructs act as a boundary
4766 -- for a transient scope.
4768 when N_Accept_Alternative
4769 | N_Attribute_Definition_Clause
4771 | N_Case_Statement_Alternative
4773 | N_Delay_Alternative
4774 | N_Delay_Until_Statement
4775 | N_Delay_Relative_Statement
4776 | N_Discriminant_Association
4778 | N_Entry_Body_Formal_Part
4781 | N_Iteration_Scheme
4782 | N_Terminate_Alternative
4784 pragma Assert
(Present
(Prev
));
4787 when N_Assignment_Statement
=>
4790 when N_Entry_Call_Statement
4791 | N_Procedure_Call_Statement
4793 -- When an entry or procedure call acts as the alternative
4794 -- of a conditional or timed entry call, the proper context
4795 -- is that of the alternative.
4797 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
4798 and then Nkind
(Parent
(Parent
(Curr
))) in
4799 N_Conditional_Entry_Call | N_Timed_Entry_Call
4801 return Parent
(Parent
(Curr
));
4803 -- General case for entry or procedure calls
4811 -- Pragma Check is not a valid transient context in
4812 -- GNATprove mode because the pragma must remain unchanged.
4815 and then Get_Pragma_Id
(Curr
) = Pragma_Check
4819 -- General case for pragmas
4825 when N_Raise_Statement
=>
4828 when N_Simple_Return_Statement
=>
4830 -- A return statement is not a valid transient context when
4831 -- the function itself requires transient scope management
4832 -- because the result will be reclaimed too early.
4834 if Requires_Transient_Scope
(Etype
4835 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
4839 -- General case for return statements
4847 when N_Attribute_Reference
=>
4848 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
4852 -- An Ada 2012 iterator specification is not a valid context
4853 -- because Analyze_Iterator_Specification already employs
4854 -- special processing for it.
4856 when N_Iterator_Specification
=>
4859 when N_Loop_Parameter_Specification
=>
4861 -- An iteration scheme is not a valid context because
4862 -- routine Analyze_Iteration_Scheme already employs
4863 -- special processing.
4865 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
4868 return Parent
(Curr
);
4873 -- The following nodes represent "dummy contexts" which do not
4874 -- need to be wrapped.
4876 when N_Component_Declaration
4877 | N_Discriminant_Specification
4878 | N_Parameter_Specification
4882 -- If the traversal leaves a scope without having been able to
4883 -- find a construct to wrap, something is going wrong, but this
4884 -- can happen in error situations that are not detected yet
4885 -- (such as a dynamic string in a pragma Export).
4887 when N_Block_Statement
4890 | N_Package_Declaration
4904 Curr
:= Parent
(Curr
);
4908 end Find_Transient_Context
;
4910 ------------------------------
4911 -- Is_Package_Or_Subprogram --
4912 ------------------------------
4914 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4916 return Ekind
(Id
) in E_Entry
4921 | E_Subprogram_Body
;
4922 end Is_Package_Or_Subprogram
;
4926 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
4929 -- Start of processing for Establish_Transient_Scope
4932 -- Do not create a new transient scope if there is already an enclosing
4933 -- transient scope within the innermost enclosing package or subprogram.
4935 if Present
(Trans_Id
) then
4937 -- If the transient scope was requested for purposes of managing the
4938 -- secondary stack, then the existing scope must perform this task.
4940 if Manage_Sec_Stack
then
4941 Set_Uses_Sec_Stack
(Trans_Id
);
4947 -- Find the construct that must be serviced by a new transient scope, if
4950 Context
:= Find_Transient_Context
(N
);
4952 if Present
(Context
) then
4953 if Nkind
(Context
) = N_Assignment_Statement
then
4955 -- An assignment statement with suppressed controlled semantics
4956 -- does not need a transient scope because finalization is not
4957 -- desirable at this point. Note that No_Ctrl_Actions is also
4958 -- set for non-controlled assignments to suppress dispatching
4961 if No_Ctrl_Actions
(Context
)
4962 and then Needs_Finalization
(Etype
(Name
(Context
)))
4964 -- When a controlled component is initialized by a function
4965 -- call, the result on the secondary stack is always assigned
4966 -- to the component. Signal the nearest suitable scope that it
4967 -- is safe to manage the secondary stack.
4969 if Manage_Sec_Stack
and then Within_Init_Proc
then
4970 Delegate_Sec_Stack_Management
;
4973 -- Otherwise the assignment is a normal transient context and thus
4974 -- requires a transient scope.
4977 Create_Transient_Scope
(Context
);
4983 Create_Transient_Scope
(Context
);
4986 end Establish_Transient_Scope
;
4988 ----------------------------
4989 -- Expand_Cleanup_Actions --
4990 ----------------------------
4992 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4994 (Nkind
(N
) in N_Block_Statement
4998 | N_Extended_Return_Statement
);
5000 Scop
: constant Entity_Id
:= Current_Scope
;
5002 Is_Asynchronous_Call
: constant Boolean :=
5003 Nkind
(N
) = N_Block_Statement
5004 and then Is_Asynchronous_Call_Block
(N
);
5005 Is_Master
: constant Boolean :=
5006 Nkind
(N
) /= N_Extended_Return_Statement
5007 and then Nkind
(N
) /= N_Entry_Body
5008 and then Is_Task_Master
(N
);
5009 Is_Protected_Subp_Body
: constant Boolean :=
5010 Nkind
(N
) = N_Subprogram_Body
5011 and then Is_Protected_Subprogram_Body
(N
);
5012 Is_Task_Allocation
: constant Boolean :=
5013 Nkind
(N
) = N_Block_Statement
5014 and then Is_Task_Allocation_Block
(N
);
5015 Is_Task_Body
: constant Boolean :=
5016 Nkind
(Original_Node
(N
)) = N_Task_Body
;
5018 -- We mark the secondary stack if it is used in this construct, and
5019 -- we're not returning a function result on the secondary stack, except
5020 -- that a build-in-place function that might or might not return on the
5021 -- secondary stack always needs a mark. A run-time test is required in
5022 -- the case where the build-in-place function has a BIP_Alloc extra
5023 -- parameter (see Create_Finalizer).
5025 Needs_Sec_Stack_Mark
: constant Boolean :=
5026 (Uses_Sec_Stack
(Scop
)
5028 not Sec_Stack_Needed_For_Return
(Scop
))
5030 (Is_Build_In_Place_Function
(Scop
)
5031 and then Needs_BIP_Alloc_Form
(Scop
));
5033 Needs_Custom_Cleanup
: constant Boolean :=
5034 Nkind
(N
) = N_Block_Statement
5035 and then Present
(Cleanup_Actions
(N
));
5037 Actions_Required
: constant Boolean :=
5038 Requires_Cleanup_Actions
(N
, True)
5039 or else Is_Asynchronous_Call
5041 or else Is_Protected_Subp_Body
5042 or else Is_Task_Allocation
5043 or else Is_Task_Body
5044 or else Needs_Sec_Stack_Mark
5045 or else Needs_Custom_Cleanup
;
5050 -- Start of processing for Expand_Cleanup_Actions
5053 -- The current construct does not need any form of servicing
5055 if not Actions_Required
then
5058 -- If the current node is a rewritten task body and the descriptors have
5059 -- not been delayed (due to some nested instantiations), do not generate
5060 -- redundant cleanup actions.
5063 and then Nkind
(N
) = N_Subprogram_Body
5064 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
5069 -- If an extended return statement contains something like
5073 -- where F is a build-in-place function call returning a controlled
5074 -- type, then a temporary object will be implicitly declared as part
5075 -- of the statement list, and this will need cleanup. In such cases,
5078 -- return Result : T := ... do
5079 -- <statements> -- possibly with handlers
5084 -- return Result : T := ... do
5085 -- declare -- no declarations
5087 -- <statements> -- possibly with handlers
5088 -- end; -- no handlers
5091 -- So Expand_Cleanup_Actions will end up being called recursively on the
5094 if Nkind
(N
) = N_Extended_Return_Statement
then
5096 Block
: constant Node_Id
:=
5097 Make_Block_Statement
(Sloc
(N
),
5098 Declarations
=> Empty_List
,
5099 Handled_Statement_Sequence
=>
5100 Handled_Statement_Sequence
(N
));
5102 Set_Handled_Statement_Sequence
(N
,
5103 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
5104 Statements
=> New_List
(Block
)));
5109 -- Analysis of the block did all the work
5114 if Needs_Custom_Cleanup
then
5115 Cln
:= Cleanup_Actions
(N
);
5120 if No
(Declarations
(N
)) then
5121 Set_Declarations
(N
, New_List
);
5125 Decls
: constant List_Id
:= Declarations
(N
);
5127 Mark
: Entity_Id
:= Empty
;
5129 -- If we are generating expanded code for debugging purposes, use the
5130 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5131 -- be updated subsequently to reference the proper line in .dg files.
5132 -- If we are not debugging generated code, use No_Location instead,
5133 -- so that no debug information is generated for the cleanup code.
5134 -- This makes the behavior of the NEXT command in GDB monotonic, and
5135 -- makes the placement of breakpoints more accurate.
5137 if Debug_Generated_Code
then
5143 -- A task activation call has already been built for a task
5144 -- allocation block.
5146 if not Is_Task_Allocation
then
5147 Build_Task_Activation_Call
(N
);
5151 Establish_Task_Master
(N
);
5154 -- If secondary stack is in use, generate:
5156 -- Mnn : constant Mark_Id := SS_Mark;
5158 if Needs_Sec_Stack_Mark
then
5159 Set_Uses_Sec_Stack
(Scop
, False); -- avoid duplicate SS marks
5160 Mark
:= Make_Temporary
(Loc
, 'M');
5163 Mark_Call
: constant Node_Id
:= Build_SS_Mark_Call
(Loc
, Mark
);
5165 Prepend_To
(Decls
, Mark_Call
);
5166 Analyze
(Mark_Call
);
5170 -- Generate finalization calls for all controlled objects appearing
5171 -- in the statements of N. Add context specific cleanup for various
5176 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5179 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5183 if Present
(Fin_Id
) then
5184 Build_Finalizer_Call
(N
, Fin_Id
);
5187 end Expand_Cleanup_Actions
;
5189 ---------------------------
5190 -- Expand_N_Package_Body --
5191 ---------------------------
5193 -- Add call to Activate_Tasks if body is an activator (actual processing
5194 -- is in chapter 9).
5196 -- Generate subprogram descriptor for elaboration routine
5198 -- Encode entity names in package body
5200 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5201 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5205 -- This is done only for non-generic packages
5207 if Ekind
(Spec_Id
) = E_Package
then
5208 -- Build dispatch tables of library-level tagged types for bodies
5209 -- that are not compilation units (see Analyze_Compilation_Unit),
5210 -- except for instances because they have no N_Compilation_Unit.
5212 if Tagged_Type_Expansion
5213 and then Is_Library_Level_Entity
(Spec_Id
)
5214 and then (not Is_Compilation_Unit
(Spec_Id
)
5215 or else Is_Generic_Instance
(Spec_Id
))
5217 Build_Static_Dispatch_Tables
(N
);
5220 Push_Scope
(Spec_Id
);
5222 Expand_CUDA_Package
(N
);
5224 Build_Task_Activation_Call
(N
);
5226 -- Verify the run-time semantics of pragma Initial_Condition at the
5227 -- end of the body statements.
5229 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5231 -- If this is a library-level package and unnesting is enabled,
5232 -- check for the presence of blocks with nested subprograms occurring
5233 -- in elaboration code, and generate procedures to encapsulate the
5234 -- blocks in case the nested subprograms make up-level references.
5236 if Unnest_Subprogram_Mode
5238 Is_Library_Level_Entity
(Current_Scope
)
5240 Check_Unnesting_Elaboration_Code
(N
);
5241 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5242 Check_Unnesting_In_Handlers
(N
);
5248 Set_Elaboration_Flag
(N
, Spec_Id
);
5249 Set_In_Package_Body
(Spec_Id
, False);
5251 -- Set to encode entity names in package body before gigi is called
5253 Qualify_Entity_Names
(N
);
5255 if Ekind
(Spec_Id
) /= E_Generic_Package
then
5258 Clean_Stmts
=> No_List
,
5260 Top_Decls
=> No_List
,
5261 Defer_Abort
=> False,
5264 if Present
(Fin_Id
) then
5265 Set_Finalizer
(Defining_Entity
(N
), Fin_Id
);
5268 end Expand_N_Package_Body
;
5270 ----------------------------------
5271 -- Expand_N_Package_Declaration --
5272 ----------------------------------
5274 -- Add call to Activate_Tasks if there are tasks declared and the package
5275 -- has no body. Note that in Ada 83 this may result in premature activation
5276 -- of some tasks, given that we cannot tell whether a body will eventually
5279 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5280 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5281 Spec
: constant Node_Id
:= Specification
(N
);
5285 No_Body
: Boolean := False;
5286 -- True in the case of a package declaration that is a compilation
5287 -- unit and for which no associated body will be compiled in this
5291 -- Case of a package declaration other than a compilation unit
5293 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5296 -- Case of a compilation unit that does not require a body
5298 elsif not Body_Required
(Parent
(N
))
5299 and then not Unit_Requires_Body
(Id
)
5303 -- Special case of generating calling stubs for a remote call interface
5304 -- package: even though the package declaration requires one, the body
5305 -- won't be processed in this compilation (so any stubs for RACWs
5306 -- declared in the package must be generated here, along with the spec).
5308 elsif Parent
(N
) = Cunit
(Main_Unit
)
5309 and then Is_Remote_Call_Interface
(Id
)
5310 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5315 -- For a nested instance, delay processing until freeze point
5317 if Has_Delayed_Freeze
(Id
)
5318 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5323 -- For a package declaration that implies no associated body, generate
5324 -- task activation call and RACW supporting bodies now (since we won't
5325 -- have a specific separate compilation unit for that).
5330 -- Generate RACW subprogram bodies
5332 if Has_RACW
(Id
) then
5333 Decls
:= Private_Declarations
(Spec
);
5336 Decls
:= Visible_Declarations
(Spec
);
5341 Set_Visible_Declarations
(Spec
, Decls
);
5344 Append_RACW_Bodies
(Decls
, Id
);
5345 Analyze_List
(Decls
);
5348 -- Generate task activation call as last step of elaboration
5350 if Present
(Activation_Chain_Entity
(N
)) then
5351 Build_Task_Activation_Call
(N
);
5354 -- Verify the run-time semantics of pragma Initial_Condition at the
5355 -- end of the private declarations when the package lacks a body.
5357 Expand_Pragma_Initial_Condition
(Id
, N
);
5362 -- Build dispatch tables of library-level tagged types for instances
5363 -- that are not compilation units (see Analyze_Compilation_Unit).
5365 if Tagged_Type_Expansion
5366 and then Is_Library_Level_Entity
(Id
)
5367 and then Is_Generic_Instance
(Id
)
5368 and then not Is_Compilation_Unit
(Id
)
5370 Build_Static_Dispatch_Tables
(N
);
5373 -- Note: it is not necessary to worry about generating a subprogram
5374 -- descriptor, since the only way to get exception handlers into a
5375 -- package spec is to include instantiations, and that would cause
5376 -- generation of subprogram descriptors to be delayed in any case.
5378 -- Set to encode entity names in package spec before gigi is called
5380 Qualify_Entity_Names
(N
);
5382 if Ekind
(Id
) /= E_Generic_Package
then
5385 Clean_Stmts
=> No_List
,
5387 Top_Decls
=> No_List
,
5388 Defer_Abort
=> False,
5391 if Present
(Fin_Id
) then
5392 Set_Finalizer
(Id
, Fin_Id
);
5396 -- If this is a library-level package and unnesting is enabled,
5397 -- check for the presence of blocks with nested subprograms occurring
5398 -- in elaboration code, and generate procedures to encapsulate the
5399 -- blocks in case the nested subprograms make up-level references.
5401 if Unnest_Subprogram_Mode
5402 and then Is_Library_Level_Entity
(Current_Scope
)
5404 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
5405 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
5407 end Expand_N_Package_Declaration
;
5409 ---------------------------------
5410 -- Has_Simple_Protected_Object --
5411 ---------------------------------
5413 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5415 if Has_Task
(T
) then
5418 elsif Is_Simple_Protected_Type
(T
) then
5421 elsif Is_Array_Type
(T
) then
5422 return Has_Simple_Protected_Object
(Component_Type
(T
));
5424 elsif Is_Record_Type
(T
) then
5429 Comp
:= First_Component
(T
);
5430 while Present
(Comp
) loop
5431 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5435 Next_Component
(Comp
);
5444 end Has_Simple_Protected_Object
;
5446 ------------------------------------
5447 -- Insert_Actions_In_Scope_Around --
5448 ------------------------------------
5450 procedure Insert_Actions_In_Scope_Around
5453 Manage_SS
: Boolean)
5455 Act_Before
: constant List_Id
:=
5456 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5457 Act_After
: constant List_Id
:=
5458 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5459 Act_Cleanup
: constant List_Id
:=
5460 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5461 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5462 -- Last), but this was incorrect as Process_Transients_In_Scope may
5463 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5465 procedure Process_Transients_In_Scope
5466 (First_Object
: Node_Id
;
5467 Last_Object
: Node_Id
;
5468 Related_Node
: Node_Id
);
5469 -- Find all transient objects in the list First_Object .. Last_Object
5470 -- and generate finalization actions for them. Related_Node denotes the
5471 -- node which created all transient objects.
5473 ---------------------------------
5474 -- Process_Transients_In_Scope --
5475 ---------------------------------
5477 procedure Process_Transients_In_Scope
5478 (First_Object
: Node_Id
;
5479 Last_Object
: Node_Id
;
5480 Related_Node
: Node_Id
)
5482 Must_Hook
: Boolean;
5483 -- Flag denoting whether the context requires transient object
5484 -- export to the outer finalizer.
5486 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5487 -- Return Abandon if arbitrary node denotes a subprogram call
5489 function Has_Subprogram_Call
is
5490 new Traverse_Func
(Is_Subprogram_Call
);
5492 procedure Process_Transient_In_Scope
5493 (Obj_Decl
: Node_Id
;
5494 Blk_Data
: Finalization_Exception_Data
;
5495 Blk_Stmts
: List_Id
);
5496 -- Generate finalization actions for a single transient object
5497 -- denoted by object declaration Obj_Decl. Blk_Data is the
5498 -- exception data of the enclosing block. Blk_Stmts denotes the
5499 -- statements of the enclosing block.
5501 ------------------------
5502 -- Is_Subprogram_Call --
5503 ------------------------
5505 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5507 -- A regular procedure or function call
5509 if Nkind
(N
) in N_Subprogram_Call
then
5514 -- Heavy expansion may relocate function calls outside the related
5515 -- node. Inspect the original node to detect the initial placement
5518 elsif Is_Rewrite_Substitution
(N
) then
5519 return Has_Subprogram_Call
(Original_Node
(N
));
5521 -- Generalized indexing always involves a function call
5523 elsif Nkind
(N
) = N_Indexed_Component
5524 and then Present
(Generalized_Indexing
(N
))
5533 end Is_Subprogram_Call
;
5535 --------------------------------
5536 -- Process_Transient_In_Scope --
5537 --------------------------------
5539 procedure Process_Transient_In_Scope
5540 (Obj_Decl
: Node_Id
;
5541 Blk_Data
: Finalization_Exception_Data
;
5542 Blk_Stmts
: List_Id
)
5544 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5545 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5547 Fin_Stmts
: List_Id
;
5548 Hook_Assign
: Node_Id
;
5549 Hook_Clear
: Node_Id
;
5550 Hook_Decl
: Node_Id
;
5551 Hook_Insert
: Node_Id
;
5555 -- Mark the transient object as successfully processed to avoid
5556 -- double finalization.
5558 Set_Is_Finalized_Transient
(Obj_Id
);
5560 -- Construct all the pieces necessary to hook and finalize the
5561 -- transient object.
5563 Build_Transient_Object_Statements
5564 (Obj_Decl
=> Obj_Decl
,
5565 Fin_Call
=> Fin_Call
,
5566 Hook_Assign
=> Hook_Assign
,
5567 Hook_Clear
=> Hook_Clear
,
5568 Hook_Decl
=> Hook_Decl
,
5569 Ptr_Decl
=> Ptr_Decl
);
5571 -- The context contains at least one subprogram call which may
5572 -- raise an exception. This scenario employs "hooking" to pass
5573 -- transient objects to the enclosing finalizer in case of an
5578 -- Add the access type which provides a reference to the
5579 -- transient object. Generate:
5581 -- type Ptr_Typ is access all Desig_Typ;
5583 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5585 -- Add the temporary which acts as a hook to the transient
5586 -- object. Generate:
5588 -- Hook : Ptr_Typ := null;
5590 Insert_Action
(Obj_Decl
, Hook_Decl
);
5592 -- When the transient object is initialized by an aggregate,
5593 -- the hook must capture the object after the last aggregate
5594 -- assignment takes place. Only then is the object considered
5595 -- fully initialized. Generate:
5597 -- Hook := Ptr_Typ (Obj_Id);
5599 -- Hook := Obj_Id'Unrestricted_Access;
5601 -- Similarly if we have a build in place call: we must
5602 -- initialize Hook only after the call has happened, otherwise
5603 -- Obj_Id will not be initialized yet.
5605 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
5606 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
5607 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5608 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
5609 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
5611 Hook_Insert
:= Obj_Decl
;
5614 -- Otherwise the hook seizes the related object immediately
5617 Hook_Insert
:= Obj_Decl
;
5620 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5623 -- When exception propagation is enabled wrap the hook clear
5624 -- statement and the finalization call into a block to catch
5625 -- potential exceptions raised during finalization. Generate:
5629 -- [Deep_]Finalize (Obj_Ref);
5633 -- if not Raised then
5636 -- (Enn, Get_Current_Excep.all.all);
5640 if Exceptions_OK
then
5641 Fin_Stmts
:= New_List
;
5644 Append_To
(Fin_Stmts
, Hook_Clear
);
5647 Append_To
(Fin_Stmts
, Fin_Call
);
5649 Prepend_To
(Blk_Stmts
,
5650 Make_Block_Statement
(Loc
,
5651 Handled_Statement_Sequence
=>
5652 Make_Handled_Sequence_Of_Statements
(Loc
,
5653 Statements
=> Fin_Stmts
,
5654 Exception_Handlers
=> New_List
(
5655 Build_Exception_Handler
(Blk_Data
)))));
5657 -- Otherwise generate:
5660 -- [Deep_]Finalize (Obj_Ref);
5662 -- Note that the statements are inserted in reverse order to
5663 -- achieve the desired final order outlined above.
5666 Prepend_To
(Blk_Stmts
, Fin_Call
);
5669 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5672 end Process_Transient_In_Scope
;
5676 Built
: Boolean := False;
5677 Blk_Data
: Finalization_Exception_Data
;
5678 Blk_Decl
: Node_Id
:= Empty
;
5679 Blk_Decls
: List_Id
:= No_List
;
5681 Blk_Stmts
: List_Id
:= No_List
;
5682 Loc
: Source_Ptr
:= No_Location
;
5685 -- Start of processing for Process_Transients_In_Scope
5688 -- The expansion performed by this routine is as follows:
5690 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5691 -- Hook_1 : Ptr_Typ_1 := null;
5692 -- Ctrl_Trans_Obj_1 : ...;
5693 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5695 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5696 -- Hook_N : Ptr_Typ_N := null;
5697 -- Ctrl_Trans_Obj_N : ...;
5698 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5701 -- Abrt : constant Boolean := ...;
5702 -- Ex : Exception_Occurrence;
5703 -- Raised : Boolean := False;
5710 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5714 -- if not Raised then
5716 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5721 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5725 -- if not Raised then
5727 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5732 -- if Raised and not Abrt then
5733 -- Raise_From_Controlled_Operation (Ex);
5737 -- Recognize a scenario where the transient context is an object
5738 -- declaration initialized by a build-in-place function call:
5740 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5742 -- The rough expansion of the above is:
5744 -- Temp : ... := Ctrl_Func_Call;
5746 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5748 -- The finalization of any transient object must happen after the
5749 -- build-in-place function call is executed.
5751 if Nkind
(N
) = N_Object_Declaration
5752 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5755 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5757 -- Search the context for at least one subprogram call. If found, the
5758 -- machinery exports all transient objects to the enclosing finalizer
5759 -- due to the possibility of abnormal call termination.
5762 Must_Hook
:= Has_Subprogram_Call
(N
) = Abandon
;
5763 Blk_Ins
:= Last_Object
;
5767 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5770 -- Examine all objects in the list First_Object .. Last_Object
5772 Obj_Decl
:= First_Object
;
5773 while Present
(Obj_Decl
) loop
5774 if Nkind
(Obj_Decl
) = N_Object_Declaration
5775 and then Analyzed
(Obj_Decl
)
5776 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5778 -- Do not process the node to be wrapped since it will be
5779 -- handled by the enclosing finalizer.
5781 and then Obj_Decl
/= Related_Node
5783 Loc
:= Sloc
(Obj_Decl
);
5785 -- Before generating the cleanup code for the first transient
5786 -- object, create a wrapper block which houses all hook clear
5787 -- statements and finalization calls. This wrapper is needed by
5792 Blk_Stmts
:= New_List
;
5795 -- Abrt : constant Boolean := ...;
5796 -- Ex : Exception_Occurrence;
5797 -- Raised : Boolean := False;
5799 if Exceptions_OK
then
5800 Blk_Decls
:= New_List
;
5801 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5805 Make_Block_Statement
(Loc
,
5806 Declarations
=> Blk_Decls
,
5807 Handled_Statement_Sequence
=>
5808 Make_Handled_Sequence_Of_Statements
(Loc
,
5809 Statements
=> Blk_Stmts
));
5812 -- Construct all necessary circuitry to hook and finalize a
5813 -- single transient object.
5815 pragma Assert
(Present
(Blk_Stmts
));
5816 Process_Transient_In_Scope
5817 (Obj_Decl
=> Obj_Decl
,
5818 Blk_Data
=> Blk_Data
,
5819 Blk_Stmts
=> Blk_Stmts
);
5822 -- Terminate the scan after the last object has been processed to
5823 -- avoid touching unrelated code.
5825 if Obj_Decl
= Last_Object
then
5832 -- Complete the decoration of the enclosing finalization block and
5833 -- insert it into the tree.
5835 if Present
(Blk_Decl
) then
5837 pragma Assert
(Present
(Blk_Stmts
));
5838 pragma Assert
(Loc
/= No_Location
);
5840 -- Note that this Abort_Undefer does not require a extra block or
5841 -- an AT_END handler because each finalization exception is caught
5842 -- in its own corresponding finalization block. As a result, the
5843 -- call to Abort_Defer always takes place.
5845 if Abort_Allowed
then
5846 Prepend_To
(Blk_Stmts
,
5847 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5849 Append_To
(Blk_Stmts
,
5850 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5854 -- if Raised and then not Abrt then
5855 -- Raise_From_Controlled_Operation (Ex);
5858 if Exceptions_OK
then
5859 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5862 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5864 end Process_Transients_In_Scope
;
5868 Loc
: constant Source_Ptr
:= Sloc
(N
);
5869 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5870 First_Obj
: Node_Id
;
5872 Mark_Id
: Entity_Id
;
5875 -- Start of processing for Insert_Actions_In_Scope_Around
5878 -- Nothing to do if the scope does not manage the secondary stack or
5879 -- does not contain meaningful actions for insertion.
5882 and then No
(Act_Before
)
5883 and then No
(Act_After
)
5884 and then No
(Act_Cleanup
)
5889 -- If the node to be wrapped is the trigger of an asynchronous select,
5890 -- it is not part of a statement list. The actions must be inserted
5891 -- before the select itself, which is part of some list of statements.
5892 -- Note that the triggering alternative includes the triggering
5893 -- statement and an optional statement list. If the node to be
5894 -- wrapped is part of that list, the normal insertion applies.
5896 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5897 and then not Is_List_Member
(Node_To_Wrap
)
5899 Target
:= Parent
(Parent
(Node_To_Wrap
));
5904 First_Obj
:= Target
;
5907 -- Add all actions associated with a transient scope into the main tree.
5908 -- There are several scenarios here:
5910 -- +--- Before ----+ +----- After ---+
5911 -- 1) First_Obj ....... Target ........ Last_Obj
5913 -- 2) First_Obj ....... Target
5915 -- 3) Target ........ Last_Obj
5917 -- Flag declarations are inserted before the first object
5919 if Present
(Act_Before
) then
5920 First_Obj
:= First
(Act_Before
);
5921 Insert_List_Before
(Target
, Act_Before
);
5924 -- Finalization calls are inserted after the last object
5926 if Present
(Act_After
) then
5927 Last_Obj
:= Last
(Act_After
);
5928 Insert_List_After
(Target
, Act_After
);
5931 -- Mark and release the secondary stack when the context warrants it
5934 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5937 -- Mnn : constant Mark_Id := SS_Mark;
5939 Insert_Before_And_Analyze
5940 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5943 -- SS_Release (Mnn);
5945 Insert_After_And_Analyze
5946 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5949 -- Check for transient objects associated with Target and generate the
5950 -- appropriate finalization actions for them.
5952 Process_Transients_In_Scope
5953 (First_Object
=> First_Obj
,
5954 Last_Object
=> Last_Obj
,
5955 Related_Node
=> Target
);
5957 -- Reset the action lists
5960 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5962 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5966 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5968 end Insert_Actions_In_Scope_Around
;
5970 ------------------------------
5971 -- Is_Simple_Protected_Type --
5972 ------------------------------
5974 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5977 Is_Protected_Type
(T
)
5978 and then not Uses_Lock_Free
(T
)
5979 and then not Has_Entries
(T
)
5980 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5981 end Is_Simple_Protected_Type
;
5983 -----------------------
5984 -- Make_Adjust_Call --
5985 -----------------------
5987 function Make_Adjust_Call
5990 Skip_Self
: Boolean := False) return Node_Id
5992 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5993 Adj_Id
: Entity_Id
:= Empty
;
6000 -- Recover the proper type which contains Deep_Adjust
6002 if Is_Class_Wide_Type
(Typ
) then
6003 Utyp
:= Root_Type
(Typ
);
6008 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
6009 Set_Assignment_OK
(Ref
);
6011 -- Deal with untagged derivation of private views
6013 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
6014 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6015 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6016 Set_Assignment_OK
(Ref
);
6019 -- When dealing with the completion of a private type, use the base
6022 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
6023 pragma Assert
(Is_Private_Type
(Typ
));
6025 Utyp
:= Base_Type
(Utyp
);
6026 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6029 -- The underlying type may not be present due to a missing full view. In
6030 -- this case freezing did not take place and there is no [Deep_]Adjust
6031 -- primitive to call.
6036 elsif Skip_Self
then
6037 if Has_Controlled_Component
(Utyp
) then
6038 if Is_Tagged_Type
(Utyp
) then
6039 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6041 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6045 -- Class-wide types, interfaces and types with controlled components
6047 elsif Is_Class_Wide_Type
(Typ
)
6048 or else Is_Interface
(Typ
)
6049 or else Has_Controlled_Component
(Utyp
)
6051 if Is_Tagged_Type
(Utyp
) then
6052 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6054 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6057 -- Derivations from [Limited_]Controlled
6059 elsif Is_Controlled
(Utyp
) then
6060 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
6064 elsif Is_Tagged_Type
(Utyp
) then
6065 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6068 raise Program_Error
;
6071 if Present
(Adj_Id
) then
6073 -- If the object is unanalyzed, set its expected type for use in
6074 -- Convert_View in case an additional conversion is needed.
6077 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
6079 Set_Etype
(Ref
, Typ
);
6082 -- The object reference may need another conversion depending on the
6083 -- type of the formal and that of the actual.
6085 if not Is_Class_Wide_Type
(Typ
) then
6086 Ref
:= Convert_View
(Adj_Id
, Ref
);
6093 Skip_Self
=> Skip_Self
);
6097 end Make_Adjust_Call
;
6105 Proc_Id
: Entity_Id
;
6107 Skip_Self
: Boolean := False) return Node_Id
6109 Params
: constant List_Id
:= New_List
(Param
);
6112 -- Do not apply the controlled action to the object itself by signaling
6113 -- the related routine to avoid self.
6116 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6120 Make_Procedure_Call_Statement
(Loc
,
6121 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6122 Parameter_Associations
=> Params
);
6125 --------------------------
6126 -- Make_Deep_Array_Body --
6127 --------------------------
6129 function Make_Deep_Array_Body
6130 (Prim
: Final_Primitives
;
6131 Typ
: Entity_Id
) return List_Id
6133 function Build_Adjust_Or_Finalize_Statements
6134 (Typ
: Entity_Id
) return List_Id
;
6135 -- Create the statements necessary to adjust or finalize an array of
6136 -- controlled elements. Generate:
6139 -- Abort : constant Boolean := Triggered_By_Abort;
6141 -- Abort : constant Boolean := False; -- no abort
6143 -- E : Exception_Occurrence;
6144 -- Raised : Boolean := False;
6147 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6148 -- ^-- in the finalization case
6150 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6152 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6156 -- if not Raised then
6158 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6165 -- if Raised and then not Abort then
6166 -- Raise_From_Controlled_Operation (E);
6170 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6171 -- Create the statements necessary to initialize an array of controlled
6172 -- elements. Include a mechanism to carry out partial finalization if an
6173 -- exception occurs. Generate:
6176 -- Counter : Integer := 0;
6179 -- for J1 in V'Range (1) loop
6181 -- for JN in V'Range (N) loop
6183 -- [Deep_]Initialize (V (J1, ..., JN));
6185 -- Counter := Counter + 1;
6190 -- Abort : constant Boolean := Triggered_By_Abort;
6192 -- Abort : constant Boolean := False; -- no abort
6193 -- E : Exception_Occurrence;
6194 -- Raised : Boolean := False;
6201 -- V'Length (N) - Counter;
6203 -- for F1 in reverse V'Range (1) loop
6205 -- for FN in reverse V'Range (N) loop
6206 -- if Counter > 0 then
6207 -- Counter := Counter - 1;
6210 -- [Deep_]Finalize (V (F1, ..., FN));
6214 -- if not Raised then
6216 -- Save_Occurrence (E,
6217 -- Get_Current_Excep.all.all);
6226 -- if Raised and then not Abort then
6227 -- Raise_From_Controlled_Operation (E);
6236 function New_References_To
6238 Loc
: Source_Ptr
) return List_Id
;
6239 -- Given a list of defining identifiers, return a list of references to
6240 -- the original identifiers, in the same order as they appear.
6242 -----------------------------------------
6243 -- Build_Adjust_Or_Finalize_Statements --
6244 -----------------------------------------
6246 function Build_Adjust_Or_Finalize_Statements
6247 (Typ
: Entity_Id
) return List_Id
6249 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6250 Index_List
: constant List_Id
:= New_List
;
6251 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6252 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6254 procedure Build_Indexes
;
6255 -- Generate the indexes used in the dimension loops
6261 procedure Build_Indexes
is
6263 -- Generate the following identifiers:
6264 -- Jnn - for initialization
6266 for Dim
in 1 .. Num_Dims
loop
6267 Append_To
(Index_List
,
6268 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6274 Final_Decls
: List_Id
:= No_List
;
6275 Final_Data
: Finalization_Exception_Data
;
6279 Core_Loop
: Node_Id
;
6282 Loop_Id
: Entity_Id
;
6285 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6288 Final_Decls
:= New_List
;
6291 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6294 Make_Indexed_Component
(Loc
,
6295 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6296 Expressions
=> New_References_To
(Index_List
, Loc
));
6297 Set_Etype
(Comp_Ref
, Comp_Typ
);
6300 -- [Deep_]Adjust (V (J1, ..., JN))
6302 if Prim
= Adjust_Case
then
6303 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6306 -- [Deep_]Finalize (V (J1, ..., JN))
6308 else pragma Assert
(Prim
= Finalize_Case
);
6309 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6312 if Present
(Call
) then
6314 -- Generate the block which houses the adjust or finalize call:
6317 -- <adjust or finalize call>
6321 -- if not Raised then
6323 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6327 if Exceptions_OK
then
6329 Make_Block_Statement
(Loc
,
6330 Handled_Statement_Sequence
=>
6331 Make_Handled_Sequence_Of_Statements
(Loc
,
6332 Statements
=> New_List
(Call
),
6333 Exception_Handlers
=> New_List
(
6334 Build_Exception_Handler
(Final_Data
))));
6339 -- Generate the dimension loops starting from the innermost one
6341 -- for Jnn in [reverse] V'Range (Dim) loop
6345 J
:= Last
(Index_List
);
6347 while Present
(J
) and then Dim
> 0 loop
6353 Make_Loop_Statement
(Loc
,
6355 Make_Iteration_Scheme
(Loc
,
6356 Loop_Parameter_Specification
=>
6357 Make_Loop_Parameter_Specification
(Loc
,
6358 Defining_Identifier
=> Loop_Id
,
6359 Discrete_Subtype_Definition
=>
6360 Make_Attribute_Reference
(Loc
,
6361 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6362 Attribute_Name
=> Name_Range
,
6363 Expressions
=> New_List
(
6364 Make_Integer_Literal
(Loc
, Dim
))),
6367 Prim
= Finalize_Case
)),
6369 Statements
=> New_List
(Core_Loop
),
6370 End_Label
=> Empty
);
6375 -- Generate the block which contains the core loop, declarations
6376 -- of the abort flag, the exception occurrence, the raised flag
6377 -- and the conditional raise:
6380 -- Abort : constant Boolean := Triggered_By_Abort;
6382 -- Abort : constant Boolean := False; -- no abort
6384 -- E : Exception_Occurrence;
6385 -- Raised : Boolean := False;
6390 -- if Raised and then not Abort then
6391 -- Raise_From_Controlled_Operation (E);
6395 Stmts
:= New_List
(Core_Loop
);
6397 if Exceptions_OK
then
6398 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6402 Make_Block_Statement
(Loc
,
6403 Declarations
=> Final_Decls
,
6404 Handled_Statement_Sequence
=>
6405 Make_Handled_Sequence_Of_Statements
(Loc
,
6406 Statements
=> Stmts
));
6408 -- Otherwise previous errors or a missing full view may prevent the
6409 -- proper freezing of the component type. If this is the case, there
6410 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6413 Block
:= Make_Null_Statement
(Loc
);
6416 return New_List
(Block
);
6417 end Build_Adjust_Or_Finalize_Statements
;
6419 ---------------------------------
6420 -- Build_Initialize_Statements --
6421 ---------------------------------
6423 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6424 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6425 Final_List
: constant List_Id
:= New_List
;
6426 Index_List
: constant List_Id
:= New_List
;
6427 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6428 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6430 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6431 -- Generate the following assignment:
6432 -- Counter := V'Length (1) *
6434 -- V'Length (N) - Counter;
6436 -- Counter_Id denotes the entity of the counter.
6438 function Build_Finalization_Call
return Node_Id
;
6439 -- Generate a deep finalization call for an array element
6441 procedure Build_Indexes
;
6442 -- Generate the initialization and finalization indexes used in the
6445 function Build_Initialization_Call
return Node_Id
;
6446 -- Generate a deep initialization call for an array element
6448 ----------------------
6449 -- Build_Assignment --
6450 ----------------------
6452 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6457 -- Start from the first dimension and generate:
6462 Make_Attribute_Reference
(Loc
,
6463 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6464 Attribute_Name
=> Name_Length
,
6465 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6467 -- Process the rest of the dimensions, generate:
6468 -- Expr * V'Length (N)
6471 while Dim
<= Num_Dims
loop
6473 Make_Op_Multiply
(Loc
,
6476 Make_Attribute_Reference
(Loc
,
6477 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6478 Attribute_Name
=> Name_Length
,
6479 Expressions
=> New_List
(
6480 Make_Integer_Literal
(Loc
, Dim
))));
6486 -- Counter := Expr - Counter;
6489 Make_Assignment_Statement
(Loc
,
6490 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6492 Make_Op_Subtract
(Loc
,
6494 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6495 end Build_Assignment
;
6497 -----------------------------
6498 -- Build_Finalization_Call --
6499 -----------------------------
6501 function Build_Finalization_Call
return Node_Id
is
6502 Comp_Ref
: constant Node_Id
:=
6503 Make_Indexed_Component
(Loc
,
6504 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6505 Expressions
=> New_References_To
(Final_List
, Loc
));
6508 Set_Etype
(Comp_Ref
, Comp_Typ
);
6511 -- [Deep_]Finalize (V);
6513 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6514 end Build_Finalization_Call
;
6520 procedure Build_Indexes
is
6522 -- Generate the following identifiers:
6523 -- Jnn - for initialization
6524 -- Fnn - for finalization
6526 for Dim
in 1 .. Num_Dims
loop
6527 Append_To
(Index_List
,
6528 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6530 Append_To
(Final_List
,
6531 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6535 -------------------------------
6536 -- Build_Initialization_Call --
6537 -------------------------------
6539 function Build_Initialization_Call
return Node_Id
is
6540 Comp_Ref
: constant Node_Id
:=
6541 Make_Indexed_Component
(Loc
,
6542 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6543 Expressions
=> New_References_To
(Index_List
, Loc
));
6546 Set_Etype
(Comp_Ref
, Comp_Typ
);
6549 -- [Deep_]Initialize (V (J1, ..., JN));
6551 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6552 end Build_Initialization_Call
;
6556 Counter_Id
: Entity_Id
;
6560 Final_Block
: Node_Id
;
6561 Final_Data
: Finalization_Exception_Data
;
6562 Final_Decls
: List_Id
:= No_List
;
6563 Final_Loop
: Node_Id
;
6564 Init_Block
: Node_Id
;
6565 Init_Call
: Node_Id
;
6566 Init_Loop
: Node_Id
;
6571 -- Start of processing for Build_Initialize_Statements
6574 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6575 Final_Decls
:= New_List
;
6578 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6580 -- Generate the block which houses the finalization call, the index
6581 -- guard and the handler which triggers Program_Error later on.
6583 -- if Counter > 0 then
6584 -- Counter := Counter - 1;
6587 -- [Deep_]Finalize (V (F1, ..., FN));
6590 -- if not Raised then
6592 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6597 Fin_Stmt
:= Build_Finalization_Call
;
6599 if Present
(Fin_Stmt
) then
6600 if Exceptions_OK
then
6602 Make_Block_Statement
(Loc
,
6603 Handled_Statement_Sequence
=>
6604 Make_Handled_Sequence_Of_Statements
(Loc
,
6605 Statements
=> New_List
(Fin_Stmt
),
6606 Exception_Handlers
=> New_List
(
6607 Build_Exception_Handler
(Final_Data
))));
6610 -- This is the core of the loop, the dimension iterators are added
6611 -- one by one in reverse.
6614 Make_If_Statement
(Loc
,
6617 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6618 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6620 Then_Statements
=> New_List
(
6621 Make_Assignment_Statement
(Loc
,
6622 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6624 Make_Op_Subtract
(Loc
,
6625 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6626 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6628 Else_Statements
=> New_List
(Fin_Stmt
));
6630 -- Generate all finalization loops starting from the innermost
6633 -- for Fnn in reverse V'Range (Dim) loop
6637 F
:= Last
(Final_List
);
6639 while Present
(F
) and then Dim
> 0 loop
6645 Make_Loop_Statement
(Loc
,
6647 Make_Iteration_Scheme
(Loc
,
6648 Loop_Parameter_Specification
=>
6649 Make_Loop_Parameter_Specification
(Loc
,
6650 Defining_Identifier
=> Loop_Id
,
6651 Discrete_Subtype_Definition
=>
6652 Make_Attribute_Reference
(Loc
,
6653 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6654 Attribute_Name
=> Name_Range
,
6655 Expressions
=> New_List
(
6656 Make_Integer_Literal
(Loc
, Dim
))),
6658 Reverse_Present
=> True)),
6660 Statements
=> New_List
(Final_Loop
),
6661 End_Label
=> Empty
);
6666 -- Generate the block which contains the finalization loops, the
6667 -- declarations of the abort flag, the exception occurrence, the
6668 -- raised flag and the conditional raise.
6671 -- Abort : constant Boolean := Triggered_By_Abort;
6673 -- Abort : constant Boolean := False; -- no abort
6675 -- E : Exception_Occurrence;
6676 -- Raised : Boolean := False;
6682 -- V'Length (N) - Counter;
6686 -- if Raised and then not Abort then
6687 -- Raise_From_Controlled_Operation (E);
6693 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6695 if Exceptions_OK
then
6696 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6697 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6701 Make_Block_Statement
(Loc
,
6702 Declarations
=> Final_Decls
,
6703 Handled_Statement_Sequence
=>
6704 Make_Handled_Sequence_Of_Statements
(Loc
,
6705 Statements
=> Stmts
));
6707 -- Otherwise previous errors or a missing full view may prevent the
6708 -- proper freezing of the component type. If this is the case, there
6709 -- is no [Deep_]Finalize primitive to call.
6712 Final_Block
:= Make_Null_Statement
(Loc
);
6715 -- Generate the block which contains the initialization call and
6716 -- the partial finalization code.
6719 -- [Deep_]Initialize (V (J1, ..., JN));
6721 -- Counter := Counter + 1;
6725 -- <finalization code>
6728 Init_Call
:= Build_Initialization_Call
;
6730 -- Only create finalization block if there is a nontrivial call
6731 -- to initialization or a Default_Initial_Condition check to be
6734 if (Present
(Init_Call
)
6735 and then Nkind
(Init_Call
) /= N_Null_Statement
)
6738 and then not GNATprove_Mode
6739 and then Present
(DIC_Procedure
(Comp_Typ
))
6740 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
6743 Init_Stmts
: constant List_Id
:= New_List
;
6746 if Present
(Init_Call
) then
6747 Append_To
(Init_Stmts
, Init_Call
);
6750 if Has_DIC
(Comp_Typ
)
6751 and then Present
(DIC_Procedure
(Comp_Typ
))
6755 Build_DIC_Call
(Loc
,
6756 Make_Indexed_Component
(Loc
,
6757 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6758 Expressions
=> New_References_To
(Index_List
, Loc
)),
6763 Make_Block_Statement
(Loc
,
6764 Handled_Statement_Sequence
=>
6765 Make_Handled_Sequence_Of_Statements
(Loc
,
6766 Statements
=> Init_Stmts
,
6767 Exception_Handlers
=> New_List
(
6768 Make_Exception_Handler
(Loc
,
6769 Exception_Choices
=> New_List
(
6770 Make_Others_Choice
(Loc
)),
6771 Statements
=> New_List
(Final_Block
)))));
6774 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6775 Make_Assignment_Statement
(Loc
,
6776 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6779 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6780 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6782 -- Generate all initialization loops starting from the innermost
6785 -- for Jnn in V'Range (Dim) loop
6789 J
:= Last
(Index_List
);
6791 while Present
(J
) and then Dim
> 0 loop
6797 Make_Loop_Statement
(Loc
,
6799 Make_Iteration_Scheme
(Loc
,
6800 Loop_Parameter_Specification
=>
6801 Make_Loop_Parameter_Specification
(Loc
,
6802 Defining_Identifier
=> Loop_Id
,
6803 Discrete_Subtype_Definition
=>
6804 Make_Attribute_Reference
(Loc
,
6805 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6806 Attribute_Name
=> Name_Range
,
6807 Expressions
=> New_List
(
6808 Make_Integer_Literal
(Loc
, Dim
))))),
6810 Statements
=> New_List
(Init_Loop
),
6811 End_Label
=> Empty
);
6816 -- Generate the block which contains the counter variable and the
6817 -- initialization loops.
6820 -- Counter : Integer := 0;
6826 Make_Block_Statement
(Loc
,
6827 Declarations
=> New_List
(
6828 Make_Object_Declaration
(Loc
,
6829 Defining_Identifier
=> Counter_Id
,
6830 Object_Definition
=>
6831 New_Occurrence_Of
(Standard_Integer
, Loc
),
6832 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6834 Handled_Statement_Sequence
=>
6835 Make_Handled_Sequence_Of_Statements
(Loc
,
6836 Statements
=> New_List
(Init_Loop
)));
6838 if Debug_Generated_Code
then
6839 Set_Debug_Info_Needed
(Counter_Id
);
6842 -- Otherwise previous errors or a missing full view may prevent the
6843 -- proper freezing of the component type. If this is the case, there
6844 -- is no [Deep_]Initialize primitive to call.
6847 Init_Block
:= Make_Null_Statement
(Loc
);
6850 return New_List
(Init_Block
);
6851 end Build_Initialize_Statements
;
6853 -----------------------
6854 -- New_References_To --
6855 -----------------------
6857 function New_References_To
6859 Loc
: Source_Ptr
) return List_Id
6861 Refs
: constant List_Id
:= New_List
;
6866 while Present
(Id
) loop
6867 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6872 end New_References_To
;
6874 -- Start of processing for Make_Deep_Array_Body
6878 when Address_Case
=>
6879 return Make_Finalize_Address_Stmts
(Typ
);
6884 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6886 when Initialize_Case
=>
6887 return Build_Initialize_Statements
(Typ
);
6889 end Make_Deep_Array_Body
;
6891 --------------------
6892 -- Make_Deep_Proc --
6893 --------------------
6895 function Make_Deep_Proc
6896 (Prim
: Final_Primitives
;
6898 Stmts
: List_Id
) return Entity_Id
6900 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6902 Proc_Id
: Entity_Id
;
6905 -- Create the object formal, generate:
6906 -- V : System.Address
6908 if Prim
= Address_Case
then
6909 Formals
:= New_List
(
6910 Make_Parameter_Specification
(Loc
,
6911 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6913 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6920 Formals
:= New_List
(
6921 Make_Parameter_Specification
(Loc
,
6922 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6924 Out_Present
=> True,
6925 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6927 -- F : Boolean := True
6929 if Prim
= Adjust_Case
6930 or else Prim
= Finalize_Case
6933 Make_Parameter_Specification
(Loc
,
6934 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6936 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6938 New_Occurrence_Of
(Standard_True
, Loc
)));
6943 Make_Defining_Identifier
(Loc
,
6944 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6947 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6950 -- exception -- Finalize and Adjust cases only
6951 -- raise Program_Error;
6952 -- end Deep_Initialize / Adjust / Finalize;
6956 -- procedure Finalize_Address (V : System.Address) is
6959 -- end Finalize_Address;
6962 Make_Subprogram_Body
(Loc
,
6964 Make_Procedure_Specification
(Loc
,
6965 Defining_Unit_Name
=> Proc_Id
,
6966 Parameter_Specifications
=> Formals
),
6968 Declarations
=> Empty_List
,
6970 Handled_Statement_Sequence
=>
6971 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6973 -- If there are no calls to component initialization, indicate that
6974 -- the procedure is trivial, so prevent calls to it.
6976 if Is_Empty_List
(Stmts
)
6977 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6979 Set_Is_Trivial_Subprogram
(Proc_Id
);
6985 ---------------------------
6986 -- Make_Deep_Record_Body --
6987 ---------------------------
6989 function Make_Deep_Record_Body
6990 (Prim
: Final_Primitives
;
6992 Is_Local
: Boolean := False) return List_Id
6994 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6995 -- Build the statements necessary to adjust a record type. The type may
6996 -- have discriminants and contain variant parts. Generate:
7000 -- [Deep_]Adjust (V.Comp_1);
7002 -- when Id : others =>
7003 -- if not Raised then
7005 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7010 -- [Deep_]Adjust (V.Comp_N);
7012 -- when Id : others =>
7013 -- if not Raised then
7015 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7020 -- Deep_Adjust (V._parent, False); -- If applicable
7022 -- when Id : others =>
7023 -- if not Raised then
7025 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7031 -- Adjust (V); -- If applicable
7034 -- if not Raised then
7036 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7041 -- if Raised and then not Abort then
7042 -- Raise_From_Controlled_Operation (E);
7046 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
7047 -- Build the statements necessary to finalize a record type. The type
7048 -- may have discriminants and contain variant parts. Generate:
7051 -- Abort : constant Boolean := Triggered_By_Abort;
7053 -- Abort : constant Boolean := False; -- no abort
7054 -- E : Exception_Occurrence;
7055 -- Raised : Boolean := False;
7060 -- Finalize (V); -- If applicable
7063 -- if not Raised then
7065 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7070 -- case Variant_1 is
7072 -- case State_Counter_N => -- If Is_Local is enabled
7082 -- <<LN>> -- If Is_Local is enabled
7084 -- [Deep_]Finalize (V.Comp_N);
7087 -- if not Raised then
7089 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7095 -- [Deep_]Finalize (V.Comp_1);
7098 -- if not Raised then
7100 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7106 -- case State_Counter_1 => -- If Is_Local is enabled
7112 -- Deep_Finalize (V._parent, False); -- If applicable
7114 -- when Id : others =>
7115 -- if not Raised then
7117 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7121 -- if Raised and then not Abort then
7122 -- Raise_From_Controlled_Operation (E);
7126 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7127 -- Given a derived tagged type Typ, traverse all components, find field
7128 -- _parent and return its type.
7130 procedure Preprocess_Components
7132 Num_Comps
: out Nat
;
7133 Has_POC
: out Boolean);
7134 -- Examine all components in component list Comps, count all controlled
7135 -- components and determine whether at least one of them is per-object
7136 -- constrained. Component _parent is always skipped.
7138 -----------------------------
7139 -- Build_Adjust_Statements --
7140 -----------------------------
7142 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7143 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7144 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7146 Finalizer_Data
: Finalization_Exception_Data
;
7148 function Process_Component_List_For_Adjust
7149 (Comps
: Node_Id
) return List_Id
;
7150 -- Build all necessary adjust statements for a single component list
7152 ---------------------------------------
7153 -- Process_Component_List_For_Adjust --
7154 ---------------------------------------
7156 function Process_Component_List_For_Adjust
7157 (Comps
: Node_Id
) return List_Id
7159 Stmts
: constant List_Id
:= New_List
;
7161 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7162 -- Process the declaration of a single controlled component
7164 ----------------------------------
7165 -- Process_Component_For_Adjust --
7166 ----------------------------------
7168 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7169 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7170 Typ
: constant Entity_Id
:= Etype
(Id
);
7176 -- [Deep_]Adjust (V.Id);
7180 -- if not Raised then
7182 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7189 Make_Selected_Component
(Loc
,
7190 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7191 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7194 -- Guard against a missing [Deep_]Adjust when the component
7195 -- type was not properly frozen.
7197 if Present
(Adj_Call
) then
7198 if Exceptions_OK
then
7200 Make_Block_Statement
(Loc
,
7201 Handled_Statement_Sequence
=>
7202 Make_Handled_Sequence_Of_Statements
(Loc
,
7203 Statements
=> New_List
(Adj_Call
),
7204 Exception_Handlers
=> New_List
(
7205 Build_Exception_Handler
(Finalizer_Data
))));
7208 Append_To
(Stmts
, Adj_Call
);
7210 end Process_Component_For_Adjust
;
7215 Decl_Id
: Entity_Id
;
7216 Decl_Typ
: Entity_Id
;
7221 -- Start of processing for Process_Component_List_For_Adjust
7224 -- Perform an initial check, determine the number of controlled
7225 -- components in the current list and whether at least one of them
7226 -- is per-object constrained.
7228 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7230 -- The processing in this routine is done in the following order:
7231 -- 1) Regular components
7232 -- 2) Per-object constrained components
7235 if Num_Comps
> 0 then
7237 -- Process all regular components in order of declarations
7239 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7240 while Present
(Decl
) loop
7241 Decl_Id
:= Defining_Identifier
(Decl
);
7242 Decl_Typ
:= Etype
(Decl_Id
);
7244 -- Skip _parent as well as per-object constrained components
7246 if Chars
(Decl_Id
) /= Name_uParent
7247 and then Needs_Finalization
(Decl_Typ
)
7249 if Has_Access_Constraint
(Decl_Id
)
7250 and then No
(Expression
(Decl
))
7254 Process_Component_For_Adjust
(Decl
);
7258 Next_Non_Pragma
(Decl
);
7261 -- Process all per-object constrained components in order of
7265 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7266 while Present
(Decl
) loop
7267 Decl_Id
:= Defining_Identifier
(Decl
);
7268 Decl_Typ
:= Etype
(Decl_Id
);
7272 if Chars
(Decl_Id
) /= Name_uParent
7273 and then Needs_Finalization
(Decl_Typ
)
7274 and then Has_Access_Constraint
(Decl_Id
)
7275 and then No
(Expression
(Decl
))
7277 Process_Component_For_Adjust
(Decl
);
7280 Next_Non_Pragma
(Decl
);
7285 -- Process all variants, if any
7288 if Present
(Variant_Part
(Comps
)) then
7290 Var_Alts
: constant List_Id
:= New_List
;
7294 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7295 while Present
(Var
) loop
7298 -- when <discrete choices> =>
7299 -- <adjust statements>
7301 Append_To
(Var_Alts
,
7302 Make_Case_Statement_Alternative
(Loc
,
7304 New_Copy_List
(Discrete_Choices
(Var
)),
7306 Process_Component_List_For_Adjust
(
7307 Component_List
(Var
))));
7309 Next_Non_Pragma
(Var
);
7313 -- case V.<discriminant> is
7314 -- when <discrete choices 1> =>
7315 -- <adjust statements 1>
7317 -- when <discrete choices N> =>
7318 -- <adjust statements N>
7322 Make_Case_Statement
(Loc
,
7324 Make_Selected_Component
(Loc
,
7325 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7327 Make_Identifier
(Loc
,
7328 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7329 Alternatives
=> Var_Alts
);
7333 -- Add the variant case statement to the list of statements
7335 if Present
(Var_Case
) then
7336 Append_To
(Stmts
, Var_Case
);
7339 -- If the component list did not have any controlled components
7340 -- nor variants, return null.
7342 if Is_Empty_List
(Stmts
) then
7343 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7347 end Process_Component_List_For_Adjust
;
7351 Bod_Stmts
: List_Id
:= No_List
;
7352 Finalizer_Decls
: List_Id
:= No_List
;
7355 -- Start of processing for Build_Adjust_Statements
7358 Finalizer_Decls
:= New_List
;
7359 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7361 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7362 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7367 -- Create an adjust sequence for all record components
7369 if Present
(Component_List
(Rec_Def
)) then
7371 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7374 -- A derived record type must adjust all inherited components. This
7375 -- action poses the following problem:
7377 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7382 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7384 -- Deep_Adjust (Obj._parent);
7389 -- Adjusting the derived type will invoke Adjust of the parent and
7390 -- then that of the derived type. This is undesirable because both
7391 -- routines may modify shared components. Only the Adjust of the
7392 -- derived type should be invoked.
7394 -- To prevent this double adjustment of shared components,
7395 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7397 -- procedure Deep_Adjust
7398 -- (Obj : in out Some_Type;
7399 -- Flag : Boolean := True)
7407 -- When Deep_Adjust is invoked for field _parent, a value of False is
7408 -- provided for the flag:
7410 -- Deep_Adjust (Obj._parent, False);
7412 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7414 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7419 if Needs_Finalization
(Par_Typ
) then
7423 Make_Selected_Component
(Loc
,
7424 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7426 Make_Identifier
(Loc
, Name_uParent
)),
7432 -- Deep_Adjust (V._parent, False);
7435 -- when Id : others =>
7436 -- if not Raised then
7438 -- Save_Occurrence (E,
7439 -- Get_Current_Excep.all.all);
7443 if Present
(Call
) then
7446 if Exceptions_OK
then
7448 Make_Block_Statement
(Loc
,
7449 Handled_Statement_Sequence
=>
7450 Make_Handled_Sequence_Of_Statements
(Loc
,
7451 Statements
=> New_List
(Adj_Stmt
),
7452 Exception_Handlers
=> New_List
(
7453 Build_Exception_Handler
(Finalizer_Data
))));
7456 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7462 -- Adjust the object. This action must be performed last after all
7463 -- components have been adjusted.
7465 if Is_Controlled
(Typ
) then
7471 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7480 -- if not Raised then
7482 -- Save_Occurrence (E,
7483 -- Get_Current_Excep.all.all);
7488 if Present
(Proc
) then
7490 Make_Procedure_Call_Statement
(Loc
,
7491 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7492 Parameter_Associations
=> New_List
(
7493 Make_Identifier
(Loc
, Name_V
)));
7495 if Exceptions_OK
then
7497 Make_Block_Statement
(Loc
,
7498 Handled_Statement_Sequence
=>
7499 Make_Handled_Sequence_Of_Statements
(Loc
,
7500 Statements
=> New_List
(Adj_Stmt
),
7501 Exception_Handlers
=> New_List
(
7502 Build_Exception_Handler
7503 (Finalizer_Data
))));
7506 Append_To
(Bod_Stmts
,
7507 Make_If_Statement
(Loc
,
7508 Condition
=> Make_Identifier
(Loc
, Name_F
),
7509 Then_Statements
=> New_List
(Adj_Stmt
)));
7514 -- At this point either all adjustment statements have been generated
7515 -- or the type is not controlled.
7517 if Is_Empty_List
(Bod_Stmts
) then
7518 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7524 -- Abort : constant Boolean := Triggered_By_Abort;
7526 -- Abort : constant Boolean := False; -- no abort
7528 -- E : Exception_Occurrence;
7529 -- Raised : Boolean := False;
7532 -- <adjust statements>
7534 -- if Raised and then not Abort then
7535 -- Raise_From_Controlled_Operation (E);
7540 if Exceptions_OK
then
7541 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7546 Make_Block_Statement
(Loc
,
7549 Handled_Statement_Sequence
=>
7550 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7552 end Build_Adjust_Statements
;
7554 -------------------------------
7555 -- Build_Finalize_Statements --
7556 -------------------------------
7558 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7559 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7560 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7563 Finalizer_Data
: Finalization_Exception_Data
;
7564 Last_POC_Call
: Node_Id
:= Empty
;
7566 function Process_Component_List_For_Finalize
7568 In_Variant_Part
: Boolean := False) return List_Id
;
7569 -- Build all necessary finalization statements for a single component
7570 -- list. The statements may include a jump circuitry if flag Is_Local
7571 -- is enabled. In_Variant_Part indicates whether this is a recursive
7574 -----------------------------------------
7575 -- Process_Component_List_For_Finalize --
7576 -----------------------------------------
7578 function Process_Component_List_For_Finalize
7580 In_Variant_Part
: Boolean := False) return List_Id
7582 procedure Process_Component_For_Finalize
7587 Num_Comps
: in out Nat
);
7588 -- Process the declaration of a single controlled component. If
7589 -- flag Is_Local is enabled, create the corresponding label and
7590 -- jump circuitry. Alts is the list of case alternatives, Decls
7591 -- is the top level declaration list where labels are declared
7592 -- and Stmts is the list of finalization actions. Num_Comps
7593 -- denotes the current number of components needing finalization.
7595 ------------------------------------
7596 -- Process_Component_For_Finalize --
7597 ------------------------------------
7599 procedure Process_Component_For_Finalize
7604 Num_Comps
: in out Nat
)
7606 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7607 Typ
: constant Entity_Id
:= Etype
(Id
);
7614 Label_Id
: Entity_Id
;
7621 Make_Identifier
(Loc
,
7622 Chars
=> New_External_Name
('L', Num_Comps
));
7623 Set_Entity
(Label_Id
,
7624 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7625 Label
:= Make_Label
(Loc
, Label_Id
);
7628 Make_Implicit_Label_Declaration
(Loc
,
7629 Defining_Identifier
=> Entity
(Label_Id
),
7630 Label_Construct
=> Label
));
7637 Make_Case_Statement_Alternative
(Loc
,
7638 Discrete_Choices
=> New_List
(
7639 Make_Integer_Literal
(Loc
, Num_Comps
)),
7641 Statements
=> New_List
(
7642 Make_Goto_Statement
(Loc
,
7644 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7649 Append_To
(Stmts
, Label
);
7651 -- Decrease the number of components to be processed.
7652 -- This action yields a new Label_Id in future calls.
7654 Num_Comps
:= Num_Comps
- 1;
7659 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7661 -- begin -- Exception handlers allowed
7662 -- [Deep_]Finalize (V.Id);
7665 -- if not Raised then
7667 -- Save_Occurrence (E,
7668 -- Get_Current_Excep.all.all);
7675 Make_Selected_Component
(Loc
,
7676 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7677 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7680 -- Guard against a missing [Deep_]Finalize when the component
7681 -- type was not properly frozen.
7683 if Present
(Fin_Call
) then
7684 if Exceptions_OK
then
7686 Make_Block_Statement
(Loc
,
7687 Handled_Statement_Sequence
=>
7688 Make_Handled_Sequence_Of_Statements
(Loc
,
7689 Statements
=> New_List
(Fin_Call
),
7690 Exception_Handlers
=> New_List
(
7691 Build_Exception_Handler
(Finalizer_Data
))));
7694 Append_To
(Stmts
, Fin_Call
);
7696 end Process_Component_For_Finalize
;
7701 Counter_Id
: Entity_Id
:= Empty
;
7703 Decl_Id
: Entity_Id
;
7704 Decl_Typ
: Entity_Id
;
7707 Jump_Block
: Node_Id
;
7709 Label_Id
: Entity_Id
;
7714 -- Start of processing for Process_Component_List_For_Finalize
7717 -- Perform an initial check, look for controlled and per-object
7718 -- constrained components.
7720 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7722 -- Create a state counter to service the current component list.
7723 -- This step is performed before the variants are inspected in
7724 -- order to generate the same state counter names as those from
7725 -- Build_Initialize_Statements.
7727 if Num_Comps
> 0 and then Is_Local
then
7728 Counter
:= Counter
+ 1;
7731 Make_Defining_Identifier
(Loc
,
7732 Chars
=> New_External_Name
('C', Counter
));
7735 -- Process the component in the following order:
7737 -- 2) Per-object constrained components
7738 -- 3) Regular components
7740 -- Start with the variant parts
7743 if Present
(Variant_Part
(Comps
)) then
7745 Var_Alts
: constant List_Id
:= New_List
;
7749 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7750 while Present
(Var
) loop
7753 -- when <discrete choices> =>
7754 -- <finalize statements>
7756 Append_To
(Var_Alts
,
7757 Make_Case_Statement_Alternative
(Loc
,
7759 New_Copy_List
(Discrete_Choices
(Var
)),
7761 Process_Component_List_For_Finalize
(
7762 Component_List
(Var
),
7763 In_Variant_Part
=> True)));
7765 Next_Non_Pragma
(Var
);
7769 -- case V.<discriminant> is
7770 -- when <discrete choices 1> =>
7771 -- <finalize statements 1>
7773 -- when <discrete choices N> =>
7774 -- <finalize statements N>
7778 Make_Case_Statement
(Loc
,
7780 Make_Selected_Component
(Loc
,
7781 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7783 Make_Identifier
(Loc
,
7784 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7785 Alternatives
=> Var_Alts
);
7789 -- The current component list does not have a single controlled
7790 -- component, however it may contain variants. Return the case
7791 -- statement for the variants or nothing.
7793 if Num_Comps
= 0 then
7794 if Present
(Var_Case
) then
7795 return New_List
(Var_Case
);
7797 return New_List
(Make_Null_Statement
(Loc
));
7801 -- Prepare all lists
7807 -- Process all per-object constrained components in reverse order
7810 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7811 while Present
(Decl
) loop
7812 Decl_Id
:= Defining_Identifier
(Decl
);
7813 Decl_Typ
:= Etype
(Decl_Id
);
7817 if Chars
(Decl_Id
) /= Name_uParent
7818 and then Needs_Finalization
(Decl_Typ
)
7819 and then Has_Access_Constraint
(Decl_Id
)
7820 and then No
(Expression
(Decl
))
7822 Process_Component_For_Finalize
7823 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7826 Prev_Non_Pragma
(Decl
);
7830 if not In_Variant_Part
then
7831 Last_POC_Call
:= Last
(Stmts
);
7832 -- In the case of a type extension, the deep-finalize call
7833 -- for the _Parent component will be inserted here.
7836 -- Process the rest of the components in reverse order
7838 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7839 while Present
(Decl
) loop
7840 Decl_Id
:= Defining_Identifier
(Decl
);
7841 Decl_Typ
:= Etype
(Decl_Id
);
7845 if Chars
(Decl_Id
) /= Name_uParent
7846 and then Needs_Finalization
(Decl_Typ
)
7848 -- Skip per-object constrained components since they were
7849 -- handled in the above step.
7851 if Has_Access_Constraint
(Decl_Id
)
7852 and then No
(Expression
(Decl
))
7856 Process_Component_For_Finalize
7857 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7861 Prev_Non_Pragma
(Decl
);
7866 -- LN : label; -- If Is_Local is enabled
7871 -- case CounterX is .
7881 -- <<LN>> -- If Is_Local is enabled
7883 -- [Deep_]Finalize (V.CompY);
7885 -- when Id : others =>
7886 -- if not Raised then
7888 -- Save_Occurrence (E,
7889 -- Get_Current_Excep.all.all);
7893 -- <<L0>> -- If Is_Local is enabled
7898 -- Add the declaration of default jump location L0, its
7899 -- corresponding alternative and its place in the statements.
7901 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7902 Set_Entity
(Label_Id
,
7903 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7904 Label
:= Make_Label
(Loc
, Label_Id
);
7906 Append_To
(Decls
, -- declaration
7907 Make_Implicit_Label_Declaration
(Loc
,
7908 Defining_Identifier
=> Entity
(Label_Id
),
7909 Label_Construct
=> Label
));
7911 Append_To
(Alts
, -- alternative
7912 Make_Case_Statement_Alternative
(Loc
,
7913 Discrete_Choices
=> New_List
(
7914 Make_Others_Choice
(Loc
)),
7916 Statements
=> New_List
(
7917 Make_Goto_Statement
(Loc
,
7918 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7920 Append_To
(Stmts
, Label
); -- statement
7922 -- Create the jump block
7925 Make_Case_Statement
(Loc
,
7926 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7927 Alternatives
=> Alts
));
7931 Make_Block_Statement
(Loc
,
7932 Declarations
=> Decls
,
7933 Handled_Statement_Sequence
=>
7934 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7936 if Present
(Var_Case
) then
7937 return New_List
(Var_Case
, Jump_Block
);
7939 return New_List
(Jump_Block
);
7941 end Process_Component_List_For_Finalize
;
7945 Bod_Stmts
: List_Id
:= No_List
;
7946 Finalizer_Decls
: List_Id
:= No_List
;
7949 -- Start of processing for Build_Finalize_Statements
7952 Finalizer_Decls
:= New_List
;
7953 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7955 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7956 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7961 -- Create a finalization sequence for all record components
7963 if Present
(Component_List
(Rec_Def
)) then
7965 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7968 -- A derived record type must finalize all inherited components. This
7969 -- action poses the following problem:
7971 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7976 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7978 -- Deep_Finalize (Obj._parent);
7983 -- Finalizing the derived type will invoke Finalize of the parent and
7984 -- then that of the derived type. This is undesirable because both
7985 -- routines may modify shared components. Only the Finalize of the
7986 -- derived type should be invoked.
7988 -- To prevent this double adjustment of shared components,
7989 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7991 -- procedure Deep_Finalize
7992 -- (Obj : in out Some_Type;
7993 -- Flag : Boolean := True)
8001 -- When Deep_Finalize is invoked for field _parent, a value of False
8002 -- is provided for the flag:
8004 -- Deep_Finalize (Obj._parent, False);
8006 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8008 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
8013 if Needs_Finalization
(Par_Typ
) then
8017 Make_Selected_Component
(Loc
,
8018 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8020 Make_Identifier
(Loc
, Name_uParent
)),
8026 -- Deep_Finalize (V._parent, False);
8029 -- when Id : others =>
8030 -- if not Raised then
8032 -- Save_Occurrence (E,
8033 -- Get_Current_Excep.all.all);
8037 if Present
(Call
) then
8040 if Exceptions_OK
then
8042 Make_Block_Statement
(Loc
,
8043 Handled_Statement_Sequence
=>
8044 Make_Handled_Sequence_Of_Statements
(Loc
,
8045 Statements
=> New_List
(Fin_Stmt
),
8046 Exception_Handlers
=> New_List
(
8047 Build_Exception_Handler
8048 (Finalizer_Data
))));
8051 -- The intended component finalization order is
8052 -- 1) POC components of extension
8053 -- 2) _Parent component
8054 -- 3) non-POC components of extension.
8056 -- With this "finalize the parent part in the middle"
8057 -- ordering, we can avoid the need for making two
8058 -- calls to the parent's subprogram in the way that
8059 -- is necessary for Init_Procs. This does have the
8060 -- peculiar (but legal) consequence that the parent's
8061 -- non-POC components are finalized before the
8062 -- non-POC extension components. This violates the
8063 -- usual "finalize in reverse declaration order"
8064 -- principle, but that's ok (see Ada RM 7.6.1(9)).
8066 -- Last_POC_Call should be non-empty if the extension
8067 -- has at least one POC. Interactions with variant
8068 -- parts are incorrectly ignored.
8070 if Present
(Last_POC_Call
) then
8071 Insert_After
(Last_POC_Call
, Fin_Stmt
);
8073 -- At this point, we could look for the common case
8074 -- where there are no POC components anywhere in
8075 -- sight (inherited or not) and, in that common case,
8076 -- call Append_To instead of Prepend_To. That would
8077 -- result in finalizing the parent part after, rather
8078 -- than before, the extension components. That might
8079 -- be more intuitive (as discussed in preceding
8080 -- comment), but it is not required.
8081 Prepend_To
(Bod_Stmts
, Fin_Stmt
);
8088 -- Finalize the object. This action must be performed first before
8089 -- all components have been finalized.
8091 if Is_Controlled
(Typ
) and then not Is_Local
then
8097 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8106 -- if not Raised then
8108 -- Save_Occurrence (E,
8109 -- Get_Current_Excep.all.all);
8114 if Present
(Proc
) then
8116 Make_Procedure_Call_Statement
(Loc
,
8117 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8118 Parameter_Associations
=> New_List
(
8119 Make_Identifier
(Loc
, Name_V
)));
8121 if Exceptions_OK
then
8123 Make_Block_Statement
(Loc
,
8124 Handled_Statement_Sequence
=>
8125 Make_Handled_Sequence_Of_Statements
(Loc
,
8126 Statements
=> New_List
(Fin_Stmt
),
8127 Exception_Handlers
=> New_List
(
8128 Build_Exception_Handler
8129 (Finalizer_Data
))));
8132 Prepend_To
(Bod_Stmts
,
8133 Make_If_Statement
(Loc
,
8134 Condition
=> Make_Identifier
(Loc
, Name_F
),
8135 Then_Statements
=> New_List
(Fin_Stmt
)));
8140 -- At this point either all finalization statements have been
8141 -- generated or the type is not controlled.
8143 if No
(Bod_Stmts
) then
8144 return New_List
(Make_Null_Statement
(Loc
));
8148 -- Abort : constant Boolean := Triggered_By_Abort;
8150 -- Abort : constant Boolean := False; -- no abort
8152 -- E : Exception_Occurrence;
8153 -- Raised : Boolean := False;
8156 -- <finalize statements>
8158 -- if Raised and then not Abort then
8159 -- Raise_From_Controlled_Operation (E);
8164 if Exceptions_OK
then
8165 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8170 Make_Block_Statement
(Loc
,
8173 Handled_Statement_Sequence
=>
8174 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8176 end Build_Finalize_Statements
;
8178 -----------------------
8179 -- Parent_Field_Type --
8180 -----------------------
8182 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8186 Field
:= First_Entity
(Typ
);
8187 while Present
(Field
) loop
8188 if Chars
(Field
) = Name_uParent
then
8189 return Etype
(Field
);
8192 Next_Entity
(Field
);
8195 -- A derived tagged type should always have a parent field
8197 raise Program_Error
;
8198 end Parent_Field_Type
;
8200 ---------------------------
8201 -- Preprocess_Components --
8202 ---------------------------
8204 procedure Preprocess_Components
8206 Num_Comps
: out Nat
;
8207 Has_POC
: out Boolean)
8217 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8218 while Present
(Decl
) loop
8219 Id
:= Defining_Identifier
(Decl
);
8222 -- Skip field _parent
8224 if Chars
(Id
) /= Name_uParent
8225 and then Needs_Finalization
(Typ
)
8227 Num_Comps
:= Num_Comps
+ 1;
8229 if Has_Access_Constraint
(Id
)
8230 and then No
(Expression
(Decl
))
8236 Next_Non_Pragma
(Decl
);
8238 end Preprocess_Components
;
8240 -- Start of processing for Make_Deep_Record_Body
8244 when Address_Case
=>
8245 return Make_Finalize_Address_Stmts
(Typ
);
8248 return Build_Adjust_Statements
(Typ
);
8250 when Finalize_Case
=>
8251 return Build_Finalize_Statements
(Typ
);
8253 when Initialize_Case
=>
8255 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8258 if Is_Controlled
(Typ
) then
8260 Make_Procedure_Call_Statement
(Loc
,
8263 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8264 Parameter_Associations
=> New_List
(
8265 Make_Identifier
(Loc
, Name_V
))));
8271 end Make_Deep_Record_Body
;
8273 ----------------------
8274 -- Make_Final_Call --
8275 ----------------------
8277 function Make_Final_Call
8280 Skip_Self
: Boolean := False) return Node_Id
8282 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8284 Prot_Typ
: Entity_Id
:= Empty
;
8285 Fin_Id
: Entity_Id
:= Empty
;
8292 -- Recover the proper type which contains [Deep_]Finalize
8294 if Is_Class_Wide_Type
(Typ
) then
8295 Utyp
:= Root_Type
(Typ
);
8298 elsif Is_Concurrent_Type
(Typ
) then
8299 Utyp
:= Corresponding_Record_Type
(Typ
);
8301 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8303 elsif Is_Private_Type
(Typ
)
8304 and then Present
(Underlying_Type
(Typ
))
8305 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8307 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8309 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8316 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8317 Set_Assignment_OK
(Ref
);
8319 -- Deal with untagged derivation of private views. If the parent type
8320 -- is a protected type, Deep_Finalize is found on the corresponding
8321 -- record of the ancestor.
8323 if Is_Untagged_Derivation
(Typ
) then
8324 if Is_Protected_Type
(Typ
) then
8325 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8327 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8329 if Is_Protected_Type
(Utyp
) then
8330 Utyp
:= Corresponding_Record_Type
(Utyp
);
8334 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8335 Set_Assignment_OK
(Ref
);
8338 -- Deal with derived private types which do not inherit primitives from
8339 -- their parents. In this case, [Deep_]Finalize can be found in the full
8340 -- view of the parent type.
8343 and then Is_Tagged_Type
(Utyp
)
8344 and then Is_Derived_Type
(Utyp
)
8345 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8346 and then Is_Private_Type
(Etype
(Utyp
))
8347 and then Present
(Full_View
(Etype
(Utyp
)))
8349 Utyp
:= Full_View
(Etype
(Utyp
));
8350 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8351 Set_Assignment_OK
(Ref
);
8354 -- When dealing with the completion of a private type, use the base type
8357 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8358 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8360 Utyp
:= Base_Type
(Utyp
);
8361 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8362 Set_Assignment_OK
(Ref
);
8365 -- Detect if Typ is a protected type or an expanded protected type and
8366 -- store the relevant type within Prot_Typ for later processing.
8368 if Is_Protected_Type
(Typ
) then
8371 elsif Ekind
(Typ
) = E_Record_Type
8372 and then Present
(Corresponding_Concurrent_Type
(Typ
))
8373 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Typ
))
8375 Prot_Typ
:= Corresponding_Concurrent_Type
(Typ
);
8378 -- The underlying type may not be present due to a missing full view. In
8379 -- this case freezing did not take place and there is no [Deep_]Finalize
8380 -- primitive to call.
8385 elsif Skip_Self
then
8386 if Has_Controlled_Component
(Utyp
) then
8387 if Is_Tagged_Type
(Utyp
) then
8388 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8390 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8394 -- Class-wide types, interfaces and types with controlled components
8396 elsif Is_Class_Wide_Type
(Typ
)
8397 or else Is_Interface
(Typ
)
8398 or else Has_Controlled_Component
(Utyp
)
8400 if Is_Tagged_Type
(Utyp
) then
8401 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8403 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8406 -- Derivations from [Limited_]Controlled
8408 elsif Is_Controlled
(Utyp
) then
8409 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8413 elsif Is_Tagged_Type
(Utyp
) then
8414 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8416 -- Protected types: these also require finalization even though they
8417 -- are not marked controlled explicitly.
8419 elsif Present
(Prot_Typ
) then
8420 -- Protected objects do not need to be finalized on restricted
8423 if Restricted_Profile
then
8426 -- ??? Only handle the simple case for now. Will not support a record
8427 -- or array containing protected objects.
8429 elsif Is_Simple_Protected_Type
(Prot_Typ
) then
8430 Fin_Id
:= RTE
(RE_Finalize_Protection
);
8432 raise Program_Error
;
8435 raise Program_Error
;
8438 if Present
(Fin_Id
) then
8440 -- When finalizing a class-wide object, do not convert to the root
8441 -- type in order to produce a dispatching call.
8443 if Is_Class_Wide_Type
(Typ
) then
8446 -- Ensure that a finalization routine is at least decorated in order
8447 -- to inspect the object parameter.
8449 elsif Analyzed
(Fin_Id
)
8450 or else Ekind
(Fin_Id
) = E_Procedure
8452 -- In certain cases, such as the creation of Stream_Read, the
8453 -- visible entity of the type is its full view. Since Stream_Read
8454 -- will have to create an object of type Typ, the local object
8455 -- will be finalzed by the scope finalizer generated later on. The
8456 -- object parameter of Deep_Finalize will always use the private
8457 -- view of the type. To avoid such a clash between a private and a
8458 -- full view, perform an unchecked conversion of the object
8459 -- reference to the private view.
8462 Formal_Typ
: constant Entity_Id
:=
8463 Etype
(First_Formal
(Fin_Id
));
8465 if Is_Private_Type
(Formal_Typ
)
8466 and then Present
(Full_View
(Formal_Typ
))
8467 and then Full_View
(Formal_Typ
) = Utyp
8469 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8473 -- If the object is unanalyzed, set its expected type for use in
8474 -- Convert_View in case an additional conversion is needed.
8477 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
8479 Set_Etype
(Ref
, Typ
);
8482 Ref
:= Convert_View
(Fin_Id
, Ref
);
8489 Skip_Self
=> Skip_Self
);
8493 end Make_Final_Call
;
8495 --------------------------------
8496 -- Make_Finalize_Address_Body --
8497 --------------------------------
8499 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8500 Is_Task
: constant Boolean :=
8501 Ekind
(Typ
) = E_Record_Type
8502 and then Is_Concurrent_Record_Type
(Typ
)
8503 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8505 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8506 Proc_Id
: Entity_Id
;
8510 -- The corresponding records of task types are not controlled by design.
8511 -- For the sake of completeness, create an empty Finalize_Address to be
8512 -- used in task class-wide allocations.
8517 -- Nothing to do if the type is not controlled or it already has a
8518 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8519 -- come from source. These are usually generated for completeness and
8520 -- do not need the Finalize_Address primitive.
8522 elsif not Needs_Finalization
(Typ
)
8523 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8525 (Is_Class_Wide_Type
(Typ
)
8526 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8527 and then not Comes_From_Source
(Root_Type
(Typ
)))
8532 -- Do not generate Finalize_Address routine for CodePeer
8534 if CodePeer_Mode
then
8539 Make_Defining_Identifier
(Loc
,
8540 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8544 -- procedure <Typ>FD (V : System.Address) is
8546 -- null; -- for tasks
8548 -- declare -- for all other types
8549 -- type Pnn is access all Typ;
8550 -- for Pnn'Storage_Size use 0;
8552 -- [Deep_]Finalize (Pnn (V).all);
8557 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8559 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8563 Make_Subprogram_Body
(Loc
,
8565 Make_Procedure_Specification
(Loc
,
8566 Defining_Unit_Name
=> Proc_Id
,
8568 Parameter_Specifications
=> New_List
(
8569 Make_Parameter_Specification
(Loc
,
8570 Defining_Identifier
=>
8571 Make_Defining_Identifier
(Loc
, Name_V
),
8573 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8575 Declarations
=> No_List
,
8577 Handled_Statement_Sequence
=>
8578 Make_Handled_Sequence_Of_Statements
(Loc
,
8579 Statements
=> Stmts
)));
8581 Set_TSS
(Typ
, Proc_Id
);
8582 end Make_Finalize_Address_Body
;
8584 ---------------------------------
8585 -- Make_Finalize_Address_Stmts --
8586 ---------------------------------
8588 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8589 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8592 Desig_Typ
: Entity_Id
;
8593 Fin_Block
: Node_Id
;
8596 Ptr_Typ
: Entity_Id
;
8599 if Is_Array_Type
(Typ
) then
8600 if Is_Constrained
(First_Subtype
(Typ
)) then
8601 Desig_Typ
:= First_Subtype
(Typ
);
8603 Desig_Typ
:= Base_Type
(Typ
);
8606 -- Class-wide types of constrained root types
8608 elsif Is_Class_Wide_Type
(Typ
)
8609 and then Has_Discriminants
(Root_Type
(Typ
))
8611 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8614 Parent_Typ
: Entity_Id
;
8617 -- Climb the parent type chain looking for a non-constrained type
8619 Parent_Typ
:= Root_Type
(Typ
);
8620 while Parent_Typ
/= Etype
(Parent_Typ
)
8621 and then Has_Discriminants
(Parent_Typ
)
8623 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8625 Parent_Typ
:= Etype
(Parent_Typ
);
8628 -- Handle views created for tagged types with unknown
8631 if Is_Underlying_Record_View
(Parent_Typ
) then
8632 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8635 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
8645 -- type Ptr_Typ is access all Typ;
8646 -- for Ptr_Typ'Storage_Size use 0;
8648 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8651 Make_Full_Type_Declaration
(Loc
,
8652 Defining_Identifier
=> Ptr_Typ
,
8654 Make_Access_To_Object_Definition
(Loc
,
8655 All_Present
=> True,
8656 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8658 Make_Attribute_Definition_Clause
(Loc
,
8659 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8660 Chars
=> Name_Storage_Size
,
8661 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8663 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8665 -- Unconstrained arrays require special processing in order to retrieve
8666 -- the elements. To achieve this, we have to skip the dope vector which
8667 -- lays in front of the elements and then use a thin pointer to perform
8668 -- the address-to-access conversion.
8670 if Is_Array_Type
(Typ
)
8671 and then not Is_Constrained
(First_Subtype
(Typ
))
8674 Dope_Id
: Entity_Id
;
8677 -- Ensure that Ptr_Typ is a thin pointer; generate:
8678 -- for Ptr_Typ'Size use System.Address'Size;
8681 Make_Attribute_Definition_Clause
(Loc
,
8682 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8685 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8688 -- Dnn : constant Storage_Offset :=
8689 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8691 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8694 Make_Object_Declaration
(Loc
,
8695 Defining_Identifier
=> Dope_Id
,
8696 Constant_Present
=> True,
8697 Object_Definition
=>
8698 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8700 Make_Op_Divide
(Loc
,
8702 Make_Attribute_Reference
(Loc
,
8703 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8704 Attribute_Name
=> Name_Descriptor_Size
),
8706 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8708 -- Shift the address from the start of the dope vector to the
8709 -- start of the elements:
8713 -- Note that this is done through a wrapper routine since RTSfind
8714 -- cannot retrieve operations with string names of the form "+".
8717 Make_Function_Call
(Loc
,
8719 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8720 Parameter_Associations
=> New_List
(
8722 New_Occurrence_Of
(Dope_Id
, Loc
)));
8729 Make_Explicit_Dereference
(Loc
,
8730 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8733 if Present
(Fin_Call
) then
8735 Make_Block_Statement
(Loc
,
8736 Declarations
=> Decls
,
8737 Handled_Statement_Sequence
=>
8738 Make_Handled_Sequence_Of_Statements
(Loc
,
8739 Statements
=> New_List
(Fin_Call
)));
8741 -- Otherwise previous errors or a missing full view may prevent the
8742 -- proper freezing of the designated type. If this is the case, there
8743 -- is no [Deep_]Finalize primitive to call.
8746 Fin_Block
:= Make_Null_Statement
(Loc
);
8749 return New_List
(Fin_Block
);
8750 end Make_Finalize_Address_Stmts
;
8752 -------------------------------------
8753 -- Make_Handler_For_Ctrl_Operation --
8754 -------------------------------------
8758 -- when E : others =>
8759 -- Raise_From_Controlled_Operation (E);
8764 -- raise Program_Error [finalize raised exception];
8766 -- depending on whether Raise_From_Controlled_Operation is available
8768 function Make_Handler_For_Ctrl_Operation
8769 (Loc
: Source_Ptr
) return Node_Id
8772 -- Choice parameter (for the first case above)
8774 Raise_Node
: Node_Id
;
8775 -- Procedure call or raise statement
8778 -- Standard run-time: add choice parameter E and pass it to
8779 -- Raise_From_Controlled_Operation so that the original exception
8780 -- name and message can be recorded in the exception message for
8783 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8784 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8786 Make_Procedure_Call_Statement
(Loc
,
8789 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8790 Parameter_Associations
=> New_List
(
8791 New_Occurrence_Of
(E_Occ
, Loc
)));
8793 -- Restricted run-time: exception messages are not supported
8798 Make_Raise_Program_Error
(Loc
,
8799 Reason
=> PE_Finalize_Raised_Exception
);
8803 Make_Implicit_Exception_Handler
(Loc
,
8804 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8805 Choice_Parameter
=> E_Occ
,
8806 Statements
=> New_List
(Raise_Node
));
8807 end Make_Handler_For_Ctrl_Operation
;
8809 --------------------
8810 -- Make_Init_Call --
8811 --------------------
8813 function Make_Init_Call
8815 Typ
: Entity_Id
) return Node_Id
8817 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8826 -- Deal with the type and object reference. Depending on the context, an
8827 -- object reference may need several conversions.
8829 if Is_Concurrent_Type
(Typ
) then
8831 Utyp
:= Corresponding_Record_Type
(Typ
);
8832 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8834 elsif Is_Private_Type
(Typ
)
8835 and then Present
(Full_View
(Typ
))
8836 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8839 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8840 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8847 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8848 Set_Assignment_OK
(Ref
);
8850 -- Deal with untagged derivation of private views
8852 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8853 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8854 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8856 -- The following is to prevent problems with UC see 1.156 RH ???
8858 Set_Assignment_OK
(Ref
);
8861 -- If the underlying_type is a subtype, then we are dealing with the
8862 -- completion of a private type. We need to access the base type and
8863 -- generate a conversion to it.
8865 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8866 pragma Assert
(Is_Private_Type
(Typ
));
8867 Utyp
:= Base_Type
(Utyp
);
8868 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8871 -- The underlying type may not be present due to a missing full view.
8872 -- In this case freezing did not take place and there is no suitable
8873 -- [Deep_]Initialize primitive to call.
8874 -- If Typ is protected then no additional processing is needed either.
8877 or else Is_Protected_Type
(Typ
)
8882 -- Select the appropriate version of initialize
8884 if Has_Controlled_Component
(Utyp
) then
8885 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8887 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8888 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8891 -- If initialization procedure for an array of controlled objects is
8892 -- trivial, do not generate a useless call to it.
8893 -- The initialization procedure may be missing altogether in the case
8894 -- of a derived container whose components have trivial initialization.
8897 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8899 (not Comes_From_Source
(Proc
)
8900 and then Present
(Alias
(Proc
))
8901 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8906 -- The object reference may need another conversion depending on the
8907 -- type of the formal and that of the actual.
8909 Ref
:= Convert_View
(Proc
, Ref
);
8912 -- [Deep_]Initialize (Ref);
8915 Make_Procedure_Call_Statement
(Loc
,
8916 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8917 Parameter_Associations
=> New_List
(Ref
));
8920 ------------------------------
8921 -- Make_Local_Deep_Finalize --
8922 ------------------------------
8924 function Make_Local_Deep_Finalize
8926 Nam
: Entity_Id
) return Node_Id
8928 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8932 Formals
:= New_List
(
8936 Make_Parameter_Specification
(Loc
,
8937 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8939 Out_Present
=> True,
8940 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8942 -- F : Boolean := True
8944 Make_Parameter_Specification
(Loc
,
8945 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8946 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8947 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8949 -- Add the necessary number of counters to represent the initialization
8950 -- state of an object.
8953 Make_Subprogram_Body
(Loc
,
8955 Make_Procedure_Specification
(Loc
,
8956 Defining_Unit_Name
=> Nam
,
8957 Parameter_Specifications
=> Formals
),
8959 Declarations
=> No_List
,
8961 Handled_Statement_Sequence
=>
8962 Make_Handled_Sequence_Of_Statements
(Loc
,
8963 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8964 end Make_Local_Deep_Finalize
;
8966 ------------------------------------
8967 -- Make_Set_Finalize_Address_Call --
8968 ------------------------------------
8970 function Make_Set_Finalize_Address_Call
8972 Ptr_Typ
: Entity_Id
) return Node_Id
8974 -- It is possible for Ptr_Typ to be a partial view, if the access type
8975 -- is a full view declared in the private part of a nested package, and
8976 -- the finalization actions take place when completing analysis of the
8977 -- enclosing unit. For this reason use Underlying_Type twice below.
8979 Desig_Typ
: constant Entity_Id
:=
8981 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8982 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8983 Fin_Mas
: constant Entity_Id
:=
8984 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8987 -- Both the finalization master and primitive Finalize_Address must be
8990 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8993 -- Set_Finalize_Address
8994 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8997 Make_Procedure_Call_Statement
(Loc
,
8999 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
9000 Parameter_Associations
=> New_List
(
9001 New_Occurrence_Of
(Fin_Mas
, Loc
),
9003 Make_Attribute_Reference
(Loc
,
9004 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
9005 Attribute_Name
=> Name_Unrestricted_Access
)));
9006 end Make_Set_Finalize_Address_Call
;
9008 --------------------------
9009 -- Make_Transient_Block --
9010 --------------------------
9012 function Make_Transient_Block
9015 Par
: Node_Id
) return Node_Id
9017 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
9018 -- Determine whether scoping entity Id manages the secondary stack
9020 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
9021 -- Return True when N appears within a loop and no block is containing N
9023 -----------------------
9024 -- Manages_Sec_Stack --
9025 -----------------------
9027 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
9031 -- An exception handler with a choice parameter utilizes a dummy
9032 -- block to provide a declarative region. Such a block should not
9033 -- be considered because it never manifests in the tree and can
9034 -- never release the secondary stack.
9038 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
9045 return Uses_Sec_Stack
(Id
);
9050 end Manages_Sec_Stack
;
9052 ---------------------------
9053 -- Within_Loop_Statement --
9054 ---------------------------
9056 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
9057 Par
: Node_Id
:= Parent
(N
);
9060 while Nkind
(Par
) not in
9061 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9062 N_Package_Specification | N_Proper_Body
9064 pragma Assert
(Present
(Par
));
9065 Par
:= Parent
(Par
);
9068 return Nkind
(Par
) = N_Loop_Statement
;
9069 end Within_Loop_Statement
;
9073 Decls
: constant List_Id
:= New_List
;
9074 Instrs
: constant List_Id
:= New_List
(Action
);
9075 Trans_Id
: constant Entity_Id
:= Current_Scope
;
9081 -- Start of processing for Make_Transient_Block
9084 -- Even though the transient block is tasked with managing the secondary
9085 -- stack, the block may forgo this functionality depending on how the
9086 -- secondary stack is managed by enclosing scopes.
9088 if Manages_Sec_Stack
(Trans_Id
) then
9090 -- Determine whether an enclosing scope already manages the secondary
9093 Scop
:= Scope
(Trans_Id
);
9094 while Present
(Scop
) loop
9096 -- It should not be possible to reach Standard without hitting one
9097 -- of the other cases first unless Standard was manually pushed.
9099 if Scop
= Standard_Standard
then
9102 -- The transient block is within a function which returns on the
9103 -- secondary stack. Take a conservative approach and assume that
9104 -- the value on the secondary stack is part of the result. Note
9105 -- that it is not possible to detect this dependency without flow
9106 -- analysis which the compiler does not have. Letting the object
9107 -- live longer than the transient block will not leak any memory
9108 -- because the caller will reclaim the total storage used by the
9111 elsif Ekind
(Scop
) = E_Function
9112 and then Sec_Stack_Needed_For_Return
(Scop
)
9114 Set_Uses_Sec_Stack
(Trans_Id
, False);
9117 -- The transient block must manage the secondary stack when the
9118 -- block appears within a loop in order to reclaim the memory at
9121 elsif Ekind
(Scop
) = E_Loop
then
9124 -- Ditto when the block appears without a block that does not
9125 -- manage the secondary stack and is located within a loop.
9127 elsif Ekind
(Scop
) = E_Block
9128 and then not Manages_Sec_Stack
(Scop
)
9129 and then Present
(Block_Node
(Scop
))
9130 and then Within_Loop_Statement
(Block_Node
(Scop
))
9134 -- The transient block does not need to manage the secondary stack
9135 -- when there is an enclosing construct which already does that.
9136 -- This optimization saves on SS_Mark and SS_Release calls but may
9137 -- allow objects to live a little longer than required.
9139 -- The transient block must manage the secondary stack when switch
9140 -- -gnatd.s (strict management) is in effect.
9142 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9143 Set_Uses_Sec_Stack
(Trans_Id
, False);
9146 -- Prevent the search from going too far because transient blocks
9147 -- are bounded by packages and subprogram scopes.
9149 elsif Ekind
(Scop
) in E_Entry
9159 Scop
:= Scope
(Scop
);
9163 -- Create the transient block. Set the parent now since the block itself
9164 -- is not part of the tree. The current scope is the E_Block entity that
9165 -- has been pushed by Establish_Transient_Scope.
9167 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9170 Make_Block_Statement
(Loc
,
9171 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9172 Declarations
=> Decls
,
9173 Handled_Statement_Sequence
=>
9174 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9175 Has_Created_Identifier
=> True);
9176 Set_Parent
(Block
, Par
);
9178 -- Insert actions stuck in the transient scopes as well as all freezing
9179 -- nodes needed by those actions. Do not insert cleanup actions here,
9180 -- they will be transferred to the newly created block.
9182 Insert_Actions_In_Scope_Around
9183 (Action
, Clean
=> False, Manage_SS
=> False);
9185 Insert
:= Prev
(Action
);
9187 if Present
(Insert
) then
9188 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9191 -- Transfer cleanup actions to the newly created block
9194 Cleanup_Actions
: List_Id
9195 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9196 Actions_To_Be_Wrapped
(Cleanup
);
9198 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9199 Cleanup_Actions
:= No_List
;
9202 -- When the transient scope was established, we pushed the entry for the
9203 -- transient scope onto the scope stack, so that the scope was active
9204 -- for the installation of finalizable entities etc. Now we must remove
9205 -- this entry, since we have constructed a proper block.
9210 end Make_Transient_Block
;
9212 ------------------------
9213 -- Node_To_Be_Wrapped --
9214 ------------------------
9216 function Node_To_Be_Wrapped
return Node_Id
is
9218 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9219 end Node_To_Be_Wrapped
;
9221 ----------------------------
9222 -- Store_Actions_In_Scope --
9223 ----------------------------
9225 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9226 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9227 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9230 if Is_Empty_List
(Actions
) then
9233 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9234 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9236 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9241 elsif AK
= Before
then
9242 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9245 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9247 end Store_Actions_In_Scope
;
9249 ----------------------------------
9250 -- Store_After_Actions_In_Scope --
9251 ----------------------------------
9253 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9255 Store_Actions_In_Scope
(After
, L
);
9256 end Store_After_Actions_In_Scope
;
9258 -----------------------------------
9259 -- Store_Before_Actions_In_Scope --
9260 -----------------------------------
9262 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9264 Store_Actions_In_Scope
(Before
, L
);
9265 end Store_Before_Actions_In_Scope
;
9267 -----------------------------------
9268 -- Store_Cleanup_Actions_In_Scope --
9269 -----------------------------------
9271 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9273 Store_Actions_In_Scope
(Cleanup
, L
);
9274 end Store_Cleanup_Actions_In_Scope
;
9280 procedure Unnest_Block
(Decl
: Node_Id
) is
9281 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9283 Local_Body
: Node_Id
;
9284 Local_Call
: Node_Id
;
9285 Local_Proc
: Entity_Id
;
9286 Local_Scop
: Entity_Id
;
9289 Local_Scop
:= Entity
(Identifier
(Decl
));
9290 Ent
:= First_Entity
(Local_Scop
);
9292 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9295 Make_Subprogram_Body
(Loc
,
9297 Make_Procedure_Specification
(Loc
,
9298 Defining_Unit_Name
=> Local_Proc
),
9299 Declarations
=> Declarations
(Decl
),
9300 Handled_Statement_Sequence
=>
9301 Handled_Statement_Sequence
(Decl
));
9303 -- Handlers in the block may contain nested subprograms that require
9306 Check_Unnesting_In_Handlers
(Local_Body
);
9308 Rewrite
(Decl
, Local_Body
);
9310 Set_Has_Nested_Subprogram
(Local_Proc
);
9313 Make_Procedure_Call_Statement
(Loc
,
9314 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9316 Insert_After
(Decl
, Local_Call
);
9317 Analyze
(Local_Call
);
9319 -- The new subprogram has the same scope as the original block
9321 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9323 -- And the entity list of the new procedure is that of the block
9325 Set_First_Entity
(Local_Proc
, Ent
);
9327 -- Reset the scopes of all the entities to the new procedure
9329 while Present
(Ent
) loop
9330 Set_Scope
(Ent
, Local_Proc
);
9335 -------------------------
9336 -- Unnest_If_Statement --
9337 -------------------------
9339 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
9341 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
9342 -- A list of statements (that may be a list associated with a then,
9343 -- elsif, or else part of an if-statement) is traversed at the top
9344 -- level to determine whether it contains a subprogram body, and if so,
9345 -- the statements will be replaced with a new procedure body containing
9346 -- the statements followed by a call to the procedure. The individual
9347 -- statements may also be blocks, loops, or other if statements that
9348 -- themselves may require contain nested subprograms needing unnesting.
9350 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
9351 Subp_Found
: Boolean := False;
9354 if Is_Empty_List
(Stmts
) then
9359 Stmt
: Node_Id
:= First
(Stmts
);
9361 while Present
(Stmt
) loop
9362 if Nkind
(Stmt
) = N_Subprogram_Body
then
9371 -- The statements themselves may be blocks, loops, etc. that in turn
9372 -- contain nested subprograms requiring an unnesting transformation.
9373 -- We perform this traversal after looking for subprogram bodies, to
9374 -- avoid considering procedures created for one of those statements
9375 -- (such as a block rewritten as a procedure) as a nested subprogram
9376 -- of the statement list (which could result in an unneeded wrapper
9379 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
9381 -- If there was a top-level subprogram body in the statement list,
9382 -- then perform an unnesting transformation on the list by replacing
9383 -- the statements with a wrapper procedure body containing the
9384 -- original statements followed by a call to that procedure.
9387 Unnest_Statement_List
(Stmts
);
9389 end Check_Stmts_For_Subp_Unnesting
;
9393 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
9394 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
9396 -- Start of processing for Unnest_If_Statement
9399 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
9400 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
9402 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
9404 Elsif_Part
: Node_Id
:=
9405 First
(Elsif_Parts
(If_Stmt
));
9406 Elsif_Stmts
: List_Id
;
9408 while Present
(Elsif_Part
) loop
9409 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
9411 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
9412 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
9419 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
9420 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
9421 end Unnest_If_Statement
;
9427 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
9428 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
9430 Local_Body
: Node_Id
;
9431 Local_Call
: Node_Id
;
9432 Local_Proc
: Entity_Id
;
9433 Local_Scop
: Entity_Id
;
9434 Loop_Copy
: constant Node_Id
:=
9435 Relocate_Node
(Loop_Stmt
);
9437 Local_Scop
:= Entity
(Identifier
(Loop_Stmt
));
9438 Ent
:= First_Entity
(Local_Scop
);
9440 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9443 Make_Subprogram_Body
(Loc
,
9445 Make_Procedure_Specification
(Loc
,
9446 Defining_Unit_Name
=> Local_Proc
),
9447 Declarations
=> Empty_List
,
9448 Handled_Statement_Sequence
=>
9449 Make_Handled_Sequence_Of_Statements
(Loc
,
9450 Statements
=> New_List
(Loop_Copy
)));
9452 Rewrite
(Loop_Stmt
, Local_Body
);
9453 Analyze
(Loop_Stmt
);
9455 Set_Has_Nested_Subprogram
(Local_Proc
);
9458 Make_Procedure_Call_Statement
(Loc
,
9459 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9461 Insert_After
(Loop_Stmt
, Local_Call
);
9462 Analyze
(Local_Call
);
9464 -- New procedure has the same scope as the original loop, and the scope
9465 -- of the loop is the new procedure.
9467 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9468 Set_Scope
(Local_Scop
, Local_Proc
);
9470 -- The entity list of the new procedure is that of the loop
9472 Set_First_Entity
(Local_Proc
, Ent
);
9474 -- Note that the entities associated with the loop don't need to have
9475 -- their Scope fields reset, since they're still associated with the
9476 -- same loop entity that now belongs to the copied loop statement.
9479 ---------------------------
9480 -- Unnest_Statement_List --
9481 ---------------------------
9483 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
9484 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
9485 Local_Body
: Node_Id
;
9486 Local_Call
: Node_Id
;
9487 Local_Proc
: Entity_Id
;
9488 New_Stmts
: constant List_Id
:= Empty_List
;
9491 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9494 Make_Subprogram_Body
(Loc
,
9496 Make_Procedure_Specification
(Loc
,
9497 Defining_Unit_Name
=> Local_Proc
),
9498 Declarations
=> Empty_List
,
9499 Handled_Statement_Sequence
=>
9500 Make_Handled_Sequence_Of_Statements
(Loc
,
9501 Statements
=> Stmts
));
9503 Append_To
(New_Stmts
, Local_Body
);
9505 Analyze
(Local_Body
);
9507 Set_Has_Nested_Subprogram
(Local_Proc
);
9510 Make_Procedure_Call_Statement
(Loc
,
9511 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9513 Append_To
(New_Stmts
, Local_Call
);
9514 Analyze
(Local_Call
);
9516 -- Traverse the statements, and for any that are declarations or
9517 -- subprogram bodies that have entities, set the Scope of those
9518 -- entities to the new procedure's Entity_Id.
9521 Stmt
: Node_Id
:= First
(Stmts
);
9524 while Present
(Stmt
) loop
9525 case Nkind
(Stmt
) is
9527 | N_Renaming_Declaration
9529 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
9531 when N_Subprogram_Body
=>
9533 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
9544 end Unnest_Statement_List
;
9546 --------------------------------
9547 -- Wrap_Transient_Declaration --
9548 --------------------------------
9550 -- If a transient scope has been established during the processing of the
9551 -- Expression of an Object_Declaration, it is not possible to wrap the
9552 -- declaration into a transient block as usual case, otherwise the object
9553 -- would be itself declared in the wrong scope. Therefore, all entities (if
9554 -- any) defined in the transient block are moved to the proper enclosing
9555 -- scope. Furthermore, if they are controlled variables they are finalized
9556 -- right after the declaration. The finalization list of the transient
9557 -- scope is defined as a renaming of the enclosing one so during their
9558 -- initialization they will be attached to the proper finalization list.
9559 -- For instance, the following declaration :
9561 -- X : Typ := F (G (A), G (B));
9563 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9564 -- is expanded into :
9566 -- X : Typ := [ complex Expression-Action ];
9567 -- [Deep_]Finalize (_v1);
9568 -- [Deep_]Finalize (_v2);
9570 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9575 Curr_S
:= Current_Scope
;
9576 Encl_S
:= Scope
(Curr_S
);
9578 -- Insert all actions including cleanup generated while analyzing or
9579 -- expanding the transient context back into the tree. Manage the
9580 -- secondary stack when the object declaration appears in a library
9581 -- level package [body].
9583 Insert_Actions_In_Scope_Around
9587 Uses_Sec_Stack
(Curr_S
)
9588 and then Nkind
(N
) = N_Object_Declaration
9589 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
9590 and then Is_Library_Level_Entity
(Encl_S
));
9593 -- Relocate local entities declared within the transient scope to the
9594 -- enclosing scope. This action sets their Is_Public flag accordingly.
9596 Transfer_Entities
(Curr_S
, Encl_S
);
9598 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9599 -- is properly released upon exiting the said scope.
9601 if Uses_Sec_Stack
(Curr_S
) then
9602 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9604 -- Do not mark a function that returns on the secondary stack as the
9605 -- reclamation is done by the caller.
9607 if Ekind
(Curr_S
) = E_Function
9608 and then Needs_Secondary_Stack
(Etype
(Curr_S
))
9612 -- Otherwise mark the enclosing dynamic scope
9615 Set_Uses_Sec_Stack
(Curr_S
);
9616 Check_Restriction
(No_Secondary_Stack
, N
);
9619 end Wrap_Transient_Declaration
;
9621 -------------------------------
9622 -- Wrap_Transient_Expression --
9623 -------------------------------
9625 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9626 Loc
: constant Source_Ptr
:= Sloc
(N
);
9627 Expr
: Node_Id
:= Relocate_Node
(N
);
9628 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9629 Typ
: constant Entity_Id
:= Etype
(N
);
9636 -- M : constant Mark_Id := SS_Mark;
9637 -- procedure Finalizer is ... (See Build_Finalizer)
9640 -- Temp := <Expr>; -- general case
9641 -- Temp := (if <Expr> then True else False); -- boolean case
9647 -- A special case is made for Boolean expressions so that the back end
9648 -- knows to generate a conditional branch instruction, if running with
9649 -- -fpreserve-control-flow. This ensures that a control-flow change
9650 -- signaling the decision outcome occurs before the cleanup actions.
9652 if Opt
.Suppress_Control_Flow_Optimizations
9653 and then Is_Boolean_Type
(Typ
)
9656 Make_If_Expression
(Loc
,
9657 Expressions
=> New_List
(
9659 New_Occurrence_Of
(Standard_True
, Loc
),
9660 New_Occurrence_Of
(Standard_False
, Loc
)));
9663 Insert_Actions
(N
, New_List
(
9664 Make_Object_Declaration
(Loc
,
9665 Defining_Identifier
=> Temp
,
9666 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9668 Make_Transient_Block
(Loc
,
9670 Make_Assignment_Statement
(Loc
,
9671 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9672 Expression
=> Expr
),
9673 Par
=> Parent
(N
))));
9675 if Debug_Generated_Code
then
9676 Set_Debug_Info_Needed
(Temp
);
9679 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9680 Analyze_And_Resolve
(N
, Typ
);
9681 end Wrap_Transient_Expression
;
9683 ------------------------------
9684 -- Wrap_Transient_Statement --
9685 ------------------------------
9687 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9688 Loc
: constant Source_Ptr
:= Sloc
(N
);
9689 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9694 -- M : constant Mark_Id := SS_Mark;
9695 -- procedure Finalizer is ... (See Build_Finalizer)
9705 Make_Transient_Block
(Loc
,
9707 Par
=> Parent
(N
)));
9709 -- With the scope stack back to normal, we can call analyze on the
9710 -- resulting block. At this point, the transient scope is being
9711 -- treated like a perfectly normal scope, so there is nothing
9712 -- special about it.
9714 -- Note: Wrap_Transient_Statement is called with the node already
9715 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9716 -- otherwise we would get a recursive processing of the node when
9717 -- we do this Analyze call.
9720 end Wrap_Transient_Statement
;