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_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
285 -- N is a construct that contains a handled sequence of statements, Fin_Id
286 -- is the entity of a finalizer. Create an At_End handler that covers the
287 -- statements of N and calls Fin_Id. If the handled statement sequence has
288 -- an exception handler, the statements will be wrapped in a block to avoid
289 -- unwanted interaction with the new At_End handler.
291 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
292 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
293 -- Has_Component_Component set and store them using the TSS mechanism.
295 -------------------------------------------
296 -- Unnesting procedures for CCG and LLVM --
297 -------------------------------------------
299 -- Expansion generates subprograms for controlled types management that
300 -- may appear in declarative lists in package declarations and bodies.
301 -- These subprograms appear within generated blocks that contain local
302 -- declarations and a call to finalization procedures. To ensure that
303 -- such subprograms get activation records when needed, we transform the
304 -- block into a procedure body, followed by a call to it in the same
307 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
308 -- The statement part of a package body that is a compilation unit may
309 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
310 -- Mode such subprograms must be handled as nested inside the (implicit)
311 -- elaboration procedure that executes that statement part. To handle
312 -- properly uplevel references we construct that subprogram explicitly,
313 -- to contain blocks and inner subprograms, the statement part becomes
314 -- a call to this subprogram. This is only done if blocks are present
315 -- in the statement list of the body. (It would be nice to unify this
316 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
317 -- they're doing very similar work, but are structured differently. ???)
319 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
320 -- Similarly, the declarations or statements in library-level packages may
321 -- have created blocks with nested subprograms. Such a block must be
322 -- transformed into a procedure followed by a call to it, so that unnesting
323 -- can handle uplevel references within these nested subprograms (typically
324 -- subprograms that handle finalization actions). This also applies to
325 -- nested packages, including instantiations, in which case it must
326 -- recursively process inner bodies.
328 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
329 -- Similarly, check for blocks with nested subprograms occurring within
330 -- a set of exception handlers associated with a package body N.
332 procedure Unnest_Block
(Decl
: Node_Id
);
333 -- Blocks that contain nested subprograms with up-level references need to
334 -- create activation records for them. We do this by rewriting the block as
335 -- a procedure, followed by a call to it in the same declarative list, to
336 -- replicate the semantics of the original block.
338 -- A common source for such block is a transient block created for a
339 -- construct (declaration, assignment, etc.) that involves controlled
340 -- actions or secondary-stack management, in which case the nested
341 -- subprogram is a finalizer.
343 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
344 -- The separate statement lists associated with an if-statement (then part,
345 -- elsif parts, else part) may require unnesting if they directly contain
346 -- a subprogram body that references up-level objects. Each statement list
347 -- is traversed to locate such subprogram bodies, and if a part's statement
348 -- list contains a body, then the list is replaced with a new procedure
349 -- containing the part's statements followed by a call to the procedure.
350 -- Furthermore, any nested blocks, loops, or if statements will also be
351 -- traversed to determine the need for further unnesting transformations.
353 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
354 -- A list of statements that directly contains a subprogram at its outer
355 -- level, that may reference objects declared in that same statement list,
356 -- is rewritten as a procedure containing the statement list Stmts (which
357 -- includes any such objects as well as the nested subprogram), followed by
358 -- a call to the new procedure, and Stmts becomes the list containing the
359 -- procedure and the call. This ensures that Unnest_Subprogram will later
360 -- properly handle up-level references from the nested subprogram to
361 -- objects declared earlier in statement list, by creating an activation
362 -- record and passing it to the nested subprogram. This procedure also
363 -- resets the Scope of objects declared in the statement list, as well as
364 -- the Scope of the nested subprogram, to refer to the new procedure.
365 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
366 -- only be called when known that the statement list contains a subprogram.
368 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
369 -- Top-level Loops that contain nested subprograms with up-level references
370 -- need to have activation records. We do this by rewriting the loop as a
371 -- procedure containing the loop, followed by a call to the procedure in
372 -- the same library-level declarative list, to replicate the semantics of
373 -- the original loop. Such loops can occur due to aggregate expansions and
376 procedure Check_Visibly_Controlled
377 (Prim
: Final_Primitives
;
379 E
: in out Entity_Id
;
380 Cref
: in out Node_Id
);
381 -- The controlled operation declared for a derived type may not be
382 -- overriding, if the controlled operations of the parent type are hidden,
383 -- for example when the parent is a private type whose full view is
384 -- controlled. For other primitive operations we modify the name of the
385 -- operation to indicate that it is not overriding, but this is not
386 -- possible for Initialize, etc. because they have to be retrievable by
387 -- name. Before generating the proper call to one of these operations we
388 -- check whether Typ is known to be controlled at the point of definition.
389 -- If it is not then we must retrieve the hidden operation of the parent
390 -- and use it instead. This is one case that might be solved more cleanly
391 -- once Overriding pragmas or declarations are in place.
393 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
394 -- Check recursively whether a loop or block contains a subprogram that
395 -- may need an activation record.
397 function Convert_View
(Proc
: Entity_Id
; Arg
: Node_Id
) return Node_Id
;
398 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
399 -- argument being passed to it. This function will, if necessary, generate
400 -- a conversion between the partial and full view of Arg to match the type
401 -- of the formal of Proc, or force a conversion to the class-wide type in
402 -- the case where the operation is abstract.
408 Skip_Self
: Boolean := False) return Node_Id
;
409 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
410 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
411 -- an adjust or finalization call. When flag Skip_Self is set, the related
412 -- action has an effect on the components only (if any).
414 function Make_Deep_Proc
415 (Prim
: Final_Primitives
;
417 Stmts
: List_Id
) return Entity_Id
;
418 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
419 -- Deep_Finalize procedures according to the first parameter. These
420 -- procedures operate on the type Typ. The Stmts parameter gives the
421 -- body of the procedure.
423 function Make_Deep_Array_Body
424 (Prim
: Final_Primitives
;
425 Typ
: Entity_Id
) return List_Id
;
426 -- This function generates the list of statements for implementing
427 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
428 -- the first parameter, these procedures operate on the array type Typ.
430 function Make_Deep_Record_Body
431 (Prim
: Final_Primitives
;
433 Is_Local
: Boolean := False) return List_Id
;
434 -- This function generates the list of statements for implementing
435 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
436 -- the first parameter, these procedures operate on the record type Typ.
437 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
438 -- whether the inner logic should be dictated by state counters.
440 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
441 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
442 -- Make_Deep_Record_Body. Generate the following statements:
445 -- type Acc_Typ is access all Typ;
446 -- for Acc_Typ'Storage_Size use 0;
448 -- [Deep_]Finalize (Acc_Typ (V).all);
451 --------------------------------
452 -- Allows_Finalization_Master --
453 --------------------------------
455 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
456 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
457 -- Determine whether entity E is inside a wrapper package created for
458 -- an instance of Ada.Unchecked_Deallocation.
460 ------------------------------
461 -- In_Deallocation_Instance --
462 ------------------------------
464 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
465 Pkg
: constant Entity_Id
:= Scope
(E
);
466 Par
: Node_Id
:= Empty
;
469 if Ekind
(Pkg
) = E_Package
470 and then Present
(Related_Instance
(Pkg
))
471 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
473 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
477 and then Chars
(Par
) = Name_Unchecked_Deallocation
478 and then Chars
(Scope
(Par
)) = Name_Ada
479 and then Scope
(Scope
(Par
)) = Standard_Standard
;
483 end In_Deallocation_Instance
;
487 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
488 Ptr_Typ
: constant Entity_Id
:=
489 Root_Type_Of_Full_View
(Base_Type
(Typ
));
491 -- Start of processing for Allows_Finalization_Master
494 -- Certain run-time configurations and targets do not provide support
495 -- for controlled types and therefore do not need masters.
497 if Restriction_Active
(No_Finalization
) then
500 -- Do not consider C and C++ types since it is assumed that the non-Ada
501 -- side will handle their cleanup.
503 elsif Convention
(Desig_Typ
) = Convention_C
504 or else Convention
(Desig_Typ
) = Convention_CPP
508 -- Do not consider an access type that returns on the secondary stack
510 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
511 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
515 -- Do not consider an access type that can never allocate an object
517 elsif No_Pool_Assigned
(Ptr_Typ
) then
520 -- Do not consider an access type coming from an Unchecked_Deallocation
521 -- instance. Even though the designated type may be controlled, the
522 -- access type will never participate in any allocations.
524 elsif In_Deallocation_Instance
(Ptr_Typ
) then
527 -- Do not consider a non-library access type when No_Nested_Finalization
528 -- is in effect since finalization masters are controlled objects and if
529 -- created will violate the restriction.
531 elsif Restriction_Active
(No_Nested_Finalization
)
532 and then not Is_Library_Level_Entity
(Ptr_Typ
)
536 -- Do not consider an access type subject to pragma No_Heap_Finalization
537 -- because objects allocated through such a type are not to be finalized
538 -- when the access type goes out of scope.
540 elsif No_Heap_Finalization
(Ptr_Typ
) then
543 -- Do not create finalization masters in GNATprove mode because this
544 -- causes unwanted extra expansion. A compilation in this mode must
545 -- keep the tree as close as possible to the original sources.
547 elsif GNATprove_Mode
then
550 -- Otherwise the access type may use a finalization master
555 end Allows_Finalization_Master
;
557 ----------------------------
558 -- Build_Anonymous_Master --
559 ----------------------------
561 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
562 function Create_Anonymous_Master
563 (Desig_Typ
: Entity_Id
;
565 Unit_Decl
: Node_Id
) return Entity_Id
;
566 -- Create a new anonymous master for access type Ptr_Typ with designated
567 -- type Desig_Typ. The declaration of the master and its initialization
568 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
569 -- the entity of Unit_Decl.
571 function Current_Anonymous_Master
572 (Desig_Typ
: Entity_Id
;
573 Unit_Id
: Entity_Id
) return Entity_Id
;
574 -- Find an anonymous master declared within unit Unit_Id which services
575 -- designated type Desig_Typ. If there is no such master, return Empty.
577 -----------------------------
578 -- Create_Anonymous_Master --
579 -----------------------------
581 function Create_Anonymous_Master
582 (Desig_Typ
: Entity_Id
;
584 Unit_Decl
: Node_Id
) return Entity_Id
586 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
597 -- <FM_Id> : Finalization_Master;
599 FM_Id
:= Make_Temporary
(Loc
, 'A');
602 Make_Object_Declaration
(Loc
,
603 Defining_Identifier
=> FM_Id
,
605 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
609 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
612 Make_Procedure_Call_Statement
(Loc
,
614 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
615 Parameter_Associations
=> New_List
(
616 New_Occurrence_Of
(FM_Id
, Loc
),
617 Make_Attribute_Reference
(Loc
,
619 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
620 Attribute_Name
=> Name_Unrestricted_Access
)));
622 -- Find the declarative list of the unit
624 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
625 Unit_Spec
:= Specification
(Unit_Decl
);
626 Decls
:= Visible_Declarations
(Unit_Spec
);
630 Set_Visible_Declarations
(Unit_Spec
, Decls
);
633 -- Package body or subprogram case
635 -- ??? A subprogram spec or body that acts as a compilation unit may
636 -- contain a formal parameter of an anonymous access-to-controlled
637 -- type initialized by an allocator.
639 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
641 -- There is no suitable place to create the master as the subprogram
642 -- is not in a declarative list.
645 Decls
:= Declarations
(Unit_Decl
);
649 Set_Declarations
(Unit_Decl
, Decls
);
653 Prepend_To
(Decls
, FM_Init
);
654 Prepend_To
(Decls
, FM_Decl
);
656 -- Use the scope of the unit when analyzing the declaration of the
657 -- master and its initialization actions.
659 Push_Scope
(Unit_Id
);
664 -- Mark the master as servicing this specific designated type
666 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
668 -- Include the anonymous master in the list of existing masters which
669 -- appear in this unit. This effectively creates a mapping between a
670 -- master and a designated type which in turn allows for the reuse of
671 -- masters on a per-unit basis.
673 All_FMs
:= Anonymous_Masters
(Unit_Id
);
676 All_FMs
:= New_Elmt_List
;
677 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
680 Prepend_Elmt
(FM_Id
, All_FMs
);
683 end Create_Anonymous_Master
;
685 ------------------------------
686 -- Current_Anonymous_Master --
687 ------------------------------
689 function Current_Anonymous_Master
690 (Desig_Typ
: Entity_Id
;
691 Unit_Id
: Entity_Id
) return Entity_Id
693 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
698 -- Inspect the list of anonymous masters declared within the unit
699 -- looking for an existing master which services the same designated
702 if Present
(All_FMs
) then
703 FM_Elmt
:= First_Elmt
(All_FMs
);
704 while Present
(FM_Elmt
) loop
705 FM_Id
:= Node
(FM_Elmt
);
707 -- The currect master services the same designated type. As a
708 -- result the master can be reused and associated with another
709 -- anonymous access-to-controlled type.
711 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
720 end Current_Anonymous_Master
;
724 Desig_Typ
: Entity_Id
;
726 Priv_View
: Entity_Id
;
730 -- Start of processing for Build_Anonymous_Master
733 -- Nothing to do if the circumstances do not allow for a finalization
736 if not Allows_Finalization_Master
(Ptr_Typ
) then
740 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
741 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
743 -- The compilation unit is a package instantiation. In this case the
744 -- anonymous master is associated with the package spec as both the
745 -- spec and body appear at the same level.
747 if Nkind
(Unit_Decl
) = N_Package_Body
748 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
750 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
751 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
754 -- Use the initial declaration of the designated type when it denotes
755 -- the full view of an incomplete or private type. This ensures that
756 -- types with one and two views are treated the same.
758 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
759 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
761 if Present
(Priv_View
) then
762 Desig_Typ
:= Priv_View
;
765 -- Determine whether the current semantic unit already has an anonymous
766 -- master which services the designated type.
768 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
770 -- If this is not the case, create a new master
773 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
776 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
777 end Build_Anonymous_Master
;
779 ----------------------------
780 -- Build_Array_Deep_Procs --
781 ----------------------------
783 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
787 (Prim
=> Initialize_Case
,
789 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
791 if not Is_Limited_View
(Typ
) then
794 (Prim
=> Adjust_Case
,
796 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
799 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
800 -- suppressed since these routine will not be used.
802 if not Restriction_Active
(No_Finalization
) then
805 (Prim
=> Finalize_Case
,
807 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
809 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
811 if not CodePeer_Mode
then
814 (Prim
=> Address_Case
,
816 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
819 end Build_Array_Deep_Procs
;
821 ------------------------------
822 -- Build_Cleanup_Statements --
823 ------------------------------
825 function Build_Cleanup_Statements
827 Additional_Cleanup
: List_Id
) return List_Id
829 Is_Asynchronous_Call
: constant Boolean :=
830 Nkind
(N
) = N_Block_Statement
and then Is_Asynchronous_Call_Block
(N
);
831 Is_Master
: constant Boolean :=
832 Nkind
(N
) /= N_Entry_Body
and then Is_Task_Master
(N
);
833 Is_Protected_Subp_Body
: constant Boolean :=
834 Nkind
(N
) = N_Subprogram_Body
835 and then Is_Protected_Subprogram_Body
(N
);
836 Is_Task_Allocation
: constant Boolean :=
837 Nkind
(N
) = N_Block_Statement
and then Is_Task_Allocation_Block
(N
);
838 Is_Task_Body
: constant Boolean :=
839 Nkind
(Original_Node
(N
)) = N_Task_Body
;
841 Loc
: constant Source_Ptr
:= Sloc
(N
);
842 Stmts
: constant List_Id
:= New_List
;
846 if Restricted_Profile
then
848 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
850 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
854 if Restriction_Active
(No_Task_Hierarchy
) = False then
855 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
858 -- Add statements to unlock the protected object parameter and to
859 -- undefer abort. If the context is a protected procedure and the object
860 -- has entries, call the entry service routine.
862 -- NOTE: The generated code references _object, a parameter to the
865 elsif Is_Protected_Subp_Body
then
867 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
868 Conc_Typ
: Entity_Id
:= Empty
;
870 Param_Typ
: Entity_Id
;
873 -- Find the _object parameter representing the protected object
875 Param
:= First
(Parameter_Specifications
(Spec
));
877 Param_Typ
:= Etype
(Parameter_Type
(Param
));
879 if Ekind
(Param_Typ
) = E_Record_Type
then
880 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
883 exit when No
(Param
) or else Present
(Conc_Typ
);
887 pragma Assert
(Present
(Param
));
888 pragma Assert
(Present
(Conc_Typ
));
890 Build_Protected_Subprogram_Call_Cleanup
891 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
894 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
895 -- tasks. Other unactivated tasks are completed by Complete_Task or
898 -- NOTE: The generated code references _chain, a local object
900 elsif Is_Task_Allocation
then
903 -- Expunge_Unactivated_Tasks (_chain);
905 -- where _chain is the list of tasks created by the allocator but not
906 -- yet activated. This list will be empty unless the block completes
910 Make_Procedure_Call_Statement
(Loc
,
913 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
914 Parameter_Associations
=> New_List
(
915 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
917 -- Attempt to cancel an asynchronous entry call whenever the block which
918 -- contains the abortable part is exited.
920 -- NOTE: The generated code references Cnn, a local object
922 elsif Is_Asynchronous_Call
then
924 Cancel_Param
: constant Entity_Id
:=
925 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
928 -- If it is of type Communication_Block, this must be a protected
929 -- entry call. Generate:
931 -- if Enqueued (Cancel_Param) then
932 -- Cancel_Protected_Entry_Call (Cancel_Param);
935 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
937 Make_If_Statement
(Loc
,
939 Make_Function_Call
(Loc
,
941 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
942 Parameter_Associations
=> New_List
(
943 New_Occurrence_Of
(Cancel_Param
, Loc
))),
945 Then_Statements
=> New_List
(
946 Make_Procedure_Call_Statement
(Loc
,
949 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
950 Parameter_Associations
=> New_List
(
951 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
953 -- Asynchronous delay, generate:
954 -- Cancel_Async_Delay (Cancel_Param);
956 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
958 Make_Procedure_Call_Statement
(Loc
,
960 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
961 Parameter_Associations
=> New_List
(
962 Make_Attribute_Reference
(Loc
,
964 New_Occurrence_Of
(Cancel_Param
, Loc
),
965 Attribute_Name
=> Name_Unchecked_Access
))));
967 -- Task entry call, generate:
968 -- Cancel_Task_Entry_Call (Cancel_Param);
972 Make_Procedure_Call_Statement
(Loc
,
974 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
975 Parameter_Associations
=> New_List
(
976 New_Occurrence_Of
(Cancel_Param
, Loc
))));
981 Append_List_To
(Stmts
, Additional_Cleanup
);
983 end Build_Cleanup_Statements
;
985 -----------------------------
986 -- Build_Controlling_Procs --
987 -----------------------------
989 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
991 if Is_Array_Type
(Typ
) then
992 Build_Array_Deep_Procs
(Typ
);
993 else pragma Assert
(Is_Record_Type
(Typ
));
994 Build_Record_Deep_Procs
(Typ
);
996 end Build_Controlling_Procs
;
998 -----------------------------
999 -- Build_Exception_Handler --
1000 -----------------------------
1002 function Build_Exception_Handler
1003 (Data
: Finalization_Exception_Data
;
1004 For_Library
: Boolean := False) return Node_Id
1007 Proc_To_Call
: Entity_Id
;
1012 pragma Assert
(Present
(Data
.Raised_Id
));
1014 if Exception_Extra_Info
1015 or else (For_Library
and not Restricted_Profile
)
1017 if Exception_Extra_Info
then
1021 -- Get_Current_Excep.all
1024 Make_Function_Call
(Data
.Loc
,
1026 Make_Explicit_Dereference
(Data
.Loc
,
1029 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1036 Except
:= Make_Null
(Data
.Loc
);
1039 if For_Library
and then not Restricted_Profile
then
1040 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1041 Actuals
:= New_List
(Except
);
1044 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1046 -- The dereference occurs only when Exception_Extra_Info is true,
1047 -- and therefore Except is not null.
1051 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1052 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1058 -- if not Raised_Id then
1059 -- Raised_Id := True;
1061 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1063 -- Save_Library_Occurrence (Get_Current_Excep.all);
1068 Make_If_Statement
(Data
.Loc
,
1070 Make_Op_Not
(Data
.Loc
,
1071 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1073 Then_Statements
=> New_List
(
1074 Make_Assignment_Statement
(Data
.Loc
,
1075 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1076 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1078 Make_Procedure_Call_Statement
(Data
.Loc
,
1080 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1081 Parameter_Associations
=> Actuals
))));
1086 -- Raised_Id := True;
1089 Make_Assignment_Statement
(Data
.Loc
,
1090 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1091 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1099 Make_Exception_Handler
(Data
.Loc
,
1100 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1101 Statements
=> Stmts
);
1102 end Build_Exception_Handler
;
1104 -------------------------------
1105 -- Build_Finalization_Master --
1106 -------------------------------
1108 procedure Build_Finalization_Master
1110 For_Lib_Level
: Boolean := False;
1111 For_Private
: Boolean := False;
1112 Context_Scope
: Entity_Id
:= Empty
;
1113 Insertion_Node
: Node_Id
:= Empty
)
1115 procedure Add_Pending_Access_Type
1117 Ptr_Typ
: Entity_Id
);
1118 -- Add access type Ptr_Typ to the pending access type list for type Typ
1120 -----------------------------
1121 -- Add_Pending_Access_Type --
1122 -----------------------------
1124 procedure Add_Pending_Access_Type
1126 Ptr_Typ
: Entity_Id
)
1131 if Present
(Pending_Access_Types
(Typ
)) then
1132 List
:= Pending_Access_Types
(Typ
);
1134 List
:= New_Elmt_List
;
1135 Set_Pending_Access_Types
(Typ
, List
);
1138 Prepend_Elmt
(Ptr_Typ
, List
);
1139 end Add_Pending_Access_Type
;
1143 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1145 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1146 -- A finalization master created for a named access type is associated
1147 -- with the full view (if applicable) as a consequence of freezing. The
1148 -- full view criteria does not apply to anonymous access types because
1149 -- those cannot have a private and a full view.
1151 -- Start of processing for Build_Finalization_Master
1154 -- Nothing to do if the circumstances do not allow for a finalization
1157 if not Allows_Finalization_Master
(Typ
) then
1160 -- Various machinery such as freezing may have already created a
1161 -- finalization master.
1163 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1168 Actions
: constant List_Id
:= New_List
;
1169 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1170 Fin_Mas_Id
: Entity_Id
;
1171 Pool_Id
: Entity_Id
;
1174 -- Source access types use fixed master names since the master is
1175 -- inserted in the same source unit only once. The only exception to
1176 -- this are instances using the same access type as generic actual.
1178 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1180 Make_Defining_Identifier
(Loc
,
1181 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1183 -- Internally generated access types use temporaries as their names
1184 -- due to possible collision with identical names coming from other
1188 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1191 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1194 -- <Ptr_Typ>FM : aliased Finalization_Master;
1197 Make_Object_Declaration
(Loc
,
1198 Defining_Identifier
=> Fin_Mas_Id
,
1199 Aliased_Present
=> True,
1200 Object_Definition
=>
1201 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1203 if Debug_Generated_Code
then
1204 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1207 -- Set the associated pool and primitive Finalize_Address of the new
1208 -- finalization master.
1210 -- The access type has a user-defined storage pool, use it
1212 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1213 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1215 -- Otherwise the default choice is the global storage pool
1218 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1219 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1223 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1226 Make_Procedure_Call_Statement
(Loc
,
1228 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1229 Parameter_Associations
=> New_List
(
1230 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1231 Make_Attribute_Reference
(Loc
,
1232 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1233 Attribute_Name
=> Name_Unrestricted_Access
))));
1235 -- Finalize_Address is not generated in CodePeer mode because the
1236 -- body contains address arithmetic. Skip this step.
1238 if CodePeer_Mode
then
1241 -- Associate the Finalize_Address primitive of the designated type
1242 -- with the finalization master of the access type. The designated
1243 -- type must be forzen as Finalize_Address is generated when the
1244 -- freeze node is expanded.
1246 elsif Is_Frozen
(Desig_Typ
)
1247 and then Present
(Finalize_Address
(Desig_Typ
))
1249 -- The finalization master of an anonymous access type may need
1250 -- to be inserted in a specific place in the tree. For instance:
1254 -- <finalization master of "access Comp_Typ">
1256 -- type Rec_Typ is record
1257 -- Comp : access Comp_Typ;
1260 -- <freeze node for Comp_Typ>
1261 -- <freeze node for Rec_Typ>
1263 -- Due to this oddity, the anonymous access type is stored for
1264 -- later processing (see below).
1266 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1269 -- Set_Finalize_Address
1270 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1273 Make_Set_Finalize_Address_Call
1275 Ptr_Typ
=> Ptr_Typ
));
1277 -- Otherwise the designated type is either anonymous access or a
1278 -- Taft-amendment type and has not been frozen. Store the access
1279 -- type for later processing (see Freeze_Type).
1282 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1285 -- A finalization master created for an access designating a type
1286 -- with private components is inserted before a context-dependent
1291 -- At this point both the scope of the context and the insertion
1292 -- mode must be known.
1294 pragma Assert
(Present
(Context_Scope
));
1295 pragma Assert
(Present
(Insertion_Node
));
1297 Push_Scope
(Context_Scope
);
1299 -- Treat use clauses as declarations and insert directly in front
1302 if Nkind
(Insertion_Node
) in
1303 N_Use_Package_Clause | N_Use_Type_Clause
1305 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1307 Insert_Actions
(Insertion_Node
, Actions
);
1312 -- The finalization master belongs to an access result type related
1313 -- to a build-in-place function call used to initialize a library
1314 -- level object. The master must be inserted in front of the access
1315 -- result type declaration denoted by Insertion_Node.
1317 elsif For_Lib_Level
then
1318 pragma Assert
(Present
(Insertion_Node
));
1319 Insert_Actions
(Insertion_Node
, Actions
);
1321 -- Otherwise the finalization master and its initialization become a
1322 -- part of the freeze node.
1325 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1328 Analyze_List
(Actions
);
1330 -- When the type the finalization master is being generated for was
1331 -- created to store a 'Old object, then mark it as such so its
1332 -- finalization can be delayed until after postconditions have been
1335 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1336 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1339 end Build_Finalization_Master
;
1341 ---------------------
1342 -- Build_Finalizer --
1343 ---------------------
1345 procedure Build_Finalizer
1347 Clean_Stmts
: List_Id
;
1348 Mark_Id
: Entity_Id
;
1349 Top_Decls
: List_Id
;
1350 Defer_Abort
: Boolean;
1351 Fin_Id
: out Entity_Id
)
1353 Acts_As_Clean
: constant Boolean :=
1356 (Present
(Clean_Stmts
)
1357 and then Is_Non_Empty_List
(Clean_Stmts
));
1359 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1360 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1361 For_Package
: constant Boolean :=
1362 For_Package_Body
or else For_Package_Spec
;
1363 Loc
: constant Source_Ptr
:= Sloc
(N
);
1365 -- NOTE: Local variable declarations are conservative and do not create
1366 -- structures right from the start. Entities and lists are created once
1367 -- it has been established that N has at least one controlled object.
1369 Components_Built
: Boolean := False;
1370 -- A flag used to avoid double initialization of entities and lists. If
1371 -- the flag is set then the following variables have been initialized:
1377 Counter_Id
: Entity_Id
:= Empty
;
1378 Counter_Val
: Nat
:= 0;
1379 -- Name and value of the state counter
1381 Decls
: List_Id
:= No_List
;
1382 -- Declarative region of N (if available). If N is a package declaration
1383 -- Decls denotes the visible declarations.
1385 Finalizer_Data
: Finalization_Exception_Data
;
1386 -- Data for the exception
1388 Finalizer_Decls
: List_Id
:= No_List
;
1389 -- Local variable declarations. This list holds the label declarations
1390 -- of all jump block alternatives as well as the declaration of the
1391 -- local exception occurrence and the raised flag:
1392 -- E : Exception_Occurrence;
1393 -- Raised : Boolean := False;
1394 -- L<counter value> : label;
1396 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1397 -- Insertion point for the finalizer body. Depending on the context
1398 -- (Nkind of N) and the individual grouping of controlled objects, this
1399 -- node may denote a package declaration or body, package instantiation,
1400 -- block statement or a counter update statement.
1402 Finalizer_Stmts
: List_Id
:= No_List
;
1403 -- The statement list of the finalizer body. It contains the following:
1405 -- Abort_Defer; -- Added if abort is allowed
1406 -- <call to Prev_At_End> -- Added if exists
1407 -- <cleanup statements> -- Added if Acts_As_Clean
1408 -- <jump block> -- Added if Has_Ctrl_Objs
1409 -- <finalization statements> -- Added if Has_Ctrl_Objs
1410 -- <stack release> -- Added if Mark_Id exists
1411 -- Abort_Undefer; -- Added if abort is allowed
1413 Has_Ctrl_Objs
: Boolean := False;
1414 -- A general flag which denotes whether N has at least one controlled
1417 Has_Tagged_Types
: Boolean := False;
1418 -- A general flag which indicates whether N has at least one library-
1419 -- level tagged type declaration.
1421 HSS
: Node_Id
:= Empty
;
1422 -- The sequence of statements of N (if available)
1424 Jump_Alts
: List_Id
:= No_List
;
1425 -- Jump block alternatives. Depending on the value of the state counter,
1426 -- the control flow jumps to a sequence of finalization statements. This
1427 -- list contains the following:
1429 -- when <counter value> =>
1430 -- goto L<counter value>;
1432 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1433 -- Specific point in the finalizer statements where the jump block is
1436 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1437 -- The last controlled construct encountered when processing the top
1438 -- level lists of N. This can be a nested package, an instantiation or
1439 -- an object declaration.
1441 Prev_At_End
: Entity_Id
:= Empty
;
1442 -- The previous at end procedure of the handled statements block of N
1444 Priv_Decls
: List_Id
:= No_List
;
1445 -- The private declarations of N if N is a package declaration
1447 Spec_Id
: Entity_Id
:= Empty
;
1448 Spec_Decls
: List_Id
:= Top_Decls
;
1449 Stmts
: List_Id
:= No_List
;
1451 Tagged_Type_Stmts
: List_Id
:= No_List
;
1452 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1453 -- tagged types found in N.
1455 -----------------------
1456 -- Local subprograms --
1457 -----------------------
1459 procedure Build_Components
;
1460 -- Create all entites and initialize all lists used in the creation of
1463 procedure Create_Finalizer
;
1464 -- Create the spec and body of the finalizer and insert them in the
1465 -- proper place in the tree depending on the context.
1467 function New_Finalizer_Name
1468 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1469 -- Create a fully qualified name of a package spec or body finalizer.
1470 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1472 procedure Process_Declarations
1474 Preprocess
: Boolean := False;
1475 Top_Level
: Boolean := False);
1476 -- Inspect a list of declarations or statements which may contain
1477 -- objects that need finalization. When flag Preprocess is set, the
1478 -- routine will simply count the total number of controlled objects in
1479 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1480 -- when Preprocess is set and if True, the processing is performed for
1481 -- objects in nested package declarations or instances.
1483 procedure Process_Object_Declaration
1485 Has_No_Init
: Boolean := False;
1486 Is_Protected
: Boolean := False);
1487 -- Generate all the machinery associated with the finalization of a
1488 -- single object. Flag Has_No_Init is used to denote certain contexts
1489 -- where Decl does not have initialization call(s). Flag Is_Protected
1490 -- is set when Decl denotes a simple protected object.
1492 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1493 -- Generate all the code necessary to unregister the external tag of a
1496 ----------------------
1497 -- Build_Components --
1498 ----------------------
1500 procedure Build_Components
is
1501 Counter_Decl
: Node_Id
;
1502 Counter_Typ
: Entity_Id
;
1503 Counter_Typ_Decl
: Node_Id
;
1506 pragma Assert
(Present
(Decls
));
1508 -- This routine might be invoked several times when dealing with
1509 -- constructs that have two lists (either two declarative regions
1510 -- or declarations and statements). Avoid double initialization.
1512 if Components_Built
then
1516 Components_Built
:= True;
1518 if Has_Ctrl_Objs
then
1520 -- Create entities for the counter, its type, the local exception
1521 -- and the raised flag.
1523 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1524 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1526 Finalizer_Decls
:= New_List
;
1528 Build_Object_Declarations
1529 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1531 -- Since the total number of controlled objects is always known,
1532 -- build a subtype of Natural with precise bounds. This allows
1533 -- the backend to optimize the case statement. Generate:
1535 -- subtype Tnn is Natural range 0 .. Counter_Val;
1538 Make_Subtype_Declaration
(Loc
,
1539 Defining_Identifier
=> Counter_Typ
,
1540 Subtype_Indication
=>
1541 Make_Subtype_Indication
(Loc
,
1542 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1544 Make_Range_Constraint
(Loc
,
1548 Make_Integer_Literal
(Loc
, Uint_0
),
1550 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1552 -- Generate the declaration of the counter itself:
1554 -- Counter : Integer := 0;
1557 Make_Object_Declaration
(Loc
,
1558 Defining_Identifier
=> Counter_Id
,
1559 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1560 Expression
=> Make_Integer_Literal
(Loc
, 0));
1562 -- Set the type of the counter explicitly to prevent errors when
1563 -- examining object declarations later on.
1565 Set_Etype
(Counter_Id
, Counter_Typ
);
1567 if Debug_Generated_Code
then
1568 Set_Debug_Info_Needed
(Counter_Id
);
1571 -- The counter and its type are inserted before the source
1572 -- declarations of N.
1574 Prepend_To
(Decls
, Counter_Decl
);
1575 Prepend_To
(Decls
, Counter_Typ_Decl
);
1577 -- The counter and its associated type must be manually analyzed
1578 -- since N has already been analyzed. Use the scope of the spec
1579 -- when inserting in a package.
1582 Push_Scope
(Spec_Id
);
1583 Analyze
(Counter_Typ_Decl
);
1584 Analyze
(Counter_Decl
);
1588 Analyze
(Counter_Typ_Decl
);
1589 Analyze
(Counter_Decl
);
1592 Jump_Alts
:= New_List
;
1595 -- If the context requires additional cleanup, the finalization
1596 -- machinery is added after the cleanup code.
1598 if Acts_As_Clean
then
1599 Finalizer_Stmts
:= Clean_Stmts
;
1600 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1602 Finalizer_Stmts
:= New_List
;
1605 if Has_Tagged_Types
then
1606 Tagged_Type_Stmts
:= New_List
;
1608 end Build_Components
;
1610 ----------------------
1611 -- Create_Finalizer --
1612 ----------------------
1614 procedure Create_Finalizer
is
1615 Body_Id
: Entity_Id
;
1618 Jump_Block
: Node_Id
;
1620 Label_Id
: Entity_Id
;
1623 -- Step 1: Creation of the finalizer name
1625 -- Packages must use a distinct name for their finalizers since the
1626 -- binder will have to generate calls to them by name. The name is
1627 -- of the following form:
1629 -- xx__yy__finalize_[spec|body]
1632 Fin_Id
:= Make_Defining_Identifier
1633 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1634 Set_Has_Qualified_Name
(Fin_Id
);
1635 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1637 -- The default name is _finalizer
1640 -- Generation of a finalization procedure exclusively for 'Old
1641 -- interally generated constants requires different name since
1642 -- there will need to be multiple finalization routines in the
1643 -- same scope. See Build_Finalizer for details.
1646 Make_Defining_Identifier
(Loc
,
1647 Chars
=> New_External_Name
(Name_uFinalizer
));
1649 -- The visibility semantics of AT_END handlers force a strange
1650 -- separation of spec and body for stack-related finalizers:
1652 -- declare : Enclosing_Scope
1653 -- procedure _finalizer;
1655 -- <controlled objects>
1656 -- procedure _finalizer is
1662 -- Both spec and body are within the same construct and scope, but
1663 -- the body is part of the handled sequence of statements. This
1664 -- placement confuses the elaboration mechanism on targets where
1665 -- AT_END handlers are expanded into "when all others" handlers:
1668 -- when all others =>
1669 -- _finalizer; -- appears to require elab checks
1674 -- Since the compiler guarantees that the body of a _finalizer is
1675 -- always inserted in the same construct where the AT_END handler
1676 -- resides, there is no need for elaboration checks.
1678 Set_Kill_Elaboration_Checks
(Fin_Id
);
1680 -- Inlining the finalizer produces a substantial speedup at -O2.
1681 -- It is inlined by default at -O3. Either way, it is called
1682 -- exactly twice (once on the normal path, and once for
1683 -- exceptions/abort), so this won't bloat the code too much.
1685 Set_Is_Inlined
(Fin_Id
);
1688 if Debug_Generated_Code
then
1689 Set_Debug_Info_Needed
(Fin_Id
);
1692 -- Step 2: Creation of the finalizer specification
1695 -- procedure Fin_Id;
1698 Make_Subprogram_Declaration
(Loc
,
1700 Make_Procedure_Specification
(Loc
,
1701 Defining_Unit_Name
=> Fin_Id
));
1704 Set_Is_Exported
(Fin_Id
);
1705 Set_Interface_Name
(Fin_Id
,
1706 Make_String_Literal
(Loc
,
1707 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1710 -- Step 3: Creation of the finalizer body
1712 -- Has_Ctrl_Objs might be set because of a generic package body having
1713 -- controlled objects. In this case, Jump_Alts may be empty and no
1714 -- case nor goto statements are needed.
1717 and then not Is_Empty_List
(Jump_Alts
)
1719 -- Add L0, the default destination to the jump block
1721 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1722 Set_Entity
(Label_Id
,
1723 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1724 Label
:= Make_Label
(Loc
, Label_Id
);
1729 Prepend_To
(Finalizer_Decls
,
1730 Make_Implicit_Label_Declaration
(Loc
,
1731 Defining_Identifier
=> Entity
(Label_Id
),
1732 Label_Construct
=> Label
));
1738 Append_To
(Jump_Alts
,
1739 Make_Case_Statement_Alternative
(Loc
,
1740 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1741 Statements
=> New_List
(
1742 Make_Goto_Statement
(Loc
,
1743 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1748 Append_To
(Finalizer_Stmts
, Label
);
1750 -- Create the jump block which controls the finalization flow
1751 -- depending on the value of the state counter.
1754 Make_Case_Statement
(Loc
,
1755 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1756 Alternatives
=> Jump_Alts
);
1758 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1759 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1761 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1765 -- Add the library-level tagged type unregistration machinery before
1766 -- the jump block circuitry. This ensures that external tags will be
1767 -- removed even if a finalization exception occurs at some point.
1769 if Has_Tagged_Types
then
1770 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1773 -- Add a call to the previous At_End handler if it exists. The call
1774 -- must always precede the jump block.
1776 if Present
(Prev_At_End
) then
1777 Prepend_To
(Finalizer_Stmts
,
1778 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1780 -- Clear the At_End handler since we have already generated the
1781 -- proper replacement call for it.
1783 Set_At_End_Proc
(HSS
, Empty
);
1786 -- Release the secondary stack
1788 if Present
(Mark_Id
) then
1790 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1793 -- If the context is a build-in-place function, the secondary
1794 -- stack must be released, unless the build-in-place function
1795 -- itself is returning on the secondary stack. Generate:
1797 -- if BIP_Alloc_Form /= Secondary_Stack then
1798 -- SS_Release (Mark_Id);
1801 -- Note that if the function returns on the secondary stack,
1802 -- then the responsibility of reclaiming the space is always
1803 -- left to the caller (recursively if needed).
1805 if Nkind
(N
) = N_Subprogram_Body
then
1807 Spec_Id
: constant Entity_Id
:=
1808 Unique_Defining_Entity
(N
);
1809 BIP_SS
: constant Boolean :=
1810 Is_Build_In_Place_Function
(Spec_Id
)
1811 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1815 Make_If_Statement
(Loc
,
1820 (Build_In_Place_Formal
1821 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1823 Make_Integer_Literal
(Loc
,
1825 (BIP_Allocation_Form
'Pos
1826 (Secondary_Stack
)))),
1828 Then_Statements
=> New_List
(Release
));
1833 Append_To
(Finalizer_Stmts
, Release
);
1837 -- Protect the statements with abort defer/undefer. This is only when
1838 -- aborts are allowed and the cleanup statements require deferral or
1839 -- there are controlled objects to be finalized. Note that the abort
1840 -- defer/undefer pair does not require an extra block because each
1841 -- finalization exception is caught in its corresponding finalization
1842 -- block. As a result, the call to Abort_Defer always takes place.
1844 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1845 Prepend_To
(Finalizer_Stmts
,
1846 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1848 Append_To
(Finalizer_Stmts
,
1849 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1852 -- The local exception does not need to be reraised for library-level
1853 -- finalizers. Note that this action must be carried out after object
1854 -- cleanup, secondary stack release, and abort undeferral. Generate:
1856 -- if Raised and then not Abort then
1857 -- Raise_From_Controlled_Operation (E);
1860 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1861 Append_To
(Finalizer_Stmts
,
1862 Build_Raise_Statement
(Finalizer_Data
));
1866 -- procedure Fin_Id is
1867 -- Abort : constant Boolean := Triggered_By_Abort;
1869 -- Abort : constant Boolean := False; -- no abort
1871 -- E : Exception_Occurrence; -- All added if flag
1872 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1878 -- Abort_Defer; -- Added if abort is allowed
1879 -- <call to Prev_At_End> -- Added if exists
1880 -- <cleanup statements> -- Added if Acts_As_Clean
1881 -- <jump block> -- Added if Has_Ctrl_Objs
1882 -- <finalization statements> -- Added if Has_Ctrl_Objs
1883 -- <stack release> -- Added if Mark_Id exists
1884 -- Abort_Undefer; -- Added if abort is allowed
1885 -- <exception propagation> -- Added if Has_Ctrl_Objs
1888 -- Create the body of the finalizer
1890 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1892 if Debug_Generated_Code
then
1893 Set_Debug_Info_Needed
(Body_Id
);
1897 Set_Has_Qualified_Name
(Body_Id
);
1898 Set_Has_Fully_Qualified_Name
(Body_Id
);
1902 Make_Subprogram_Body
(Loc
,
1904 Make_Procedure_Specification
(Loc
,
1905 Defining_Unit_Name
=> Body_Id
),
1906 Declarations
=> Finalizer_Decls
,
1907 Handled_Statement_Sequence
=>
1908 Make_Handled_Sequence_Of_Statements
(Loc
,
1909 Statements
=> Finalizer_Stmts
));
1911 -- Step 4: Spec and body insertion, analysis
1915 -- If the package spec has private declarations, the finalizer
1916 -- body must be added to the end of the list in order to have
1917 -- visibility of all private controlled objects.
1919 if For_Package_Spec
then
1920 if Present
(Priv_Decls
) then
1921 Append_To
(Priv_Decls
, Fin_Spec
);
1922 Append_To
(Priv_Decls
, Fin_Body
);
1924 Append_To
(Decls
, Fin_Spec
);
1925 Append_To
(Decls
, Fin_Body
);
1928 -- For package bodies, both the finalizer spec and body are
1929 -- inserted at the end of the package declarations.
1932 Append_To
(Decls
, Fin_Spec
);
1933 Append_To
(Decls
, Fin_Body
);
1936 -- Push the name of the package
1938 Push_Scope
(Spec_Id
);
1946 -- Create the spec for the finalizer. The At_End handler must be
1947 -- able to call the body which resides in a nested structure.
1951 -- procedure Fin_Id; -- Spec
1953 -- <objects and possibly statements>
1954 -- procedure Fin_Id is ... -- Body
1957 -- Fin_Id; -- At_End handler
1960 pragma Assert
(Present
(Spec_Decls
));
1962 -- It maybe possible that we are finalizing 'Old objects which
1963 -- exist in the spec declarations. When this is the case the
1964 -- Finalizer_Insert_Node will come before the end of the
1965 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1966 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1967 -- end of Spec_Decls to prevent its body appearing before its
1968 -- corresponding spec.
1970 if Present
(Finalizer_Insert_Nod
)
1971 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
1973 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
1974 Finalizer_Insert_Nod
:= Fin_Spec
;
1976 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
1979 Append_To
(Spec_Decls
, Fin_Spec
);
1983 -- When the finalizer acts solely as a cleanup routine, the body
1984 -- is inserted right after the spec.
1986 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1987 Insert_After
(Fin_Spec
, Fin_Body
);
1989 -- In all other cases the body is inserted after either:
1991 -- 1) The counter update statement of the last controlled object
1992 -- 2) The last top level nested controlled package
1993 -- 3) The last top level controlled instantiation
1996 -- Manually freeze the spec. This is somewhat of a hack because
1997 -- a subprogram is frozen when its body is seen and the freeze
1998 -- node appears right before the body. However, in this case,
1999 -- the spec must be frozen earlier since the At_End handler
2000 -- must be able to call it.
2003 -- procedure Fin_Id; -- Spec
2004 -- [Fin_Id] -- Freeze node
2008 -- Fin_Id; -- At_End handler
2011 Ensure_Freeze_Node
(Fin_Id
);
2012 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2013 Set_Is_Frozen
(Fin_Id
);
2015 -- In the case where the last construct to contain a controlled
2016 -- object is either a nested package, an instantiation or a
2017 -- freeze node, the body must be inserted directly after the
2018 -- construct, except if the insertion point is already placed
2019 -- after the construct, typically in the statement list.
2021 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2022 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2024 (List_Containing
(Last_Top_Level_Ctrl_Construct
) = Spec_Decls
2025 and then Present
(Stmts
)
2026 and then List_Containing
(Finalizer_Insert_Nod
) = Stmts
)
2028 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2031 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2034 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2037 -- Never consider that the finalizer procedure is enabled Ghost, even
2038 -- when the corresponding unit is Ghost, as this would lead to an
2039 -- an external name with a ___ghost_ prefix that the binder cannot
2040 -- generate, as it has no knowledge of the Ghost status of units.
2042 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2043 end Create_Finalizer
;
2045 ------------------------
2046 -- New_Finalizer_Name --
2047 ------------------------
2049 function New_Finalizer_Name
2050 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2052 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2053 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2054 -- has a non-standard scope, process the scope first.
2056 ------------------------
2057 -- New_Finalizer_Name --
2058 ------------------------
2060 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2062 if Scope
(Id
) = Standard_Standard
then
2063 Get_Name_String
(Chars
(Id
));
2066 New_Finalizer_Name
(Scope
(Id
));
2067 Add_Str_To_Name_Buffer
("__");
2068 Get_Name_String_And_Append
(Chars
(Id
));
2070 end New_Finalizer_Name
;
2072 -- Start of processing for New_Finalizer_Name
2075 -- Create the fully qualified name of the enclosing scope
2077 New_Finalizer_Name
(Spec_Id
);
2080 -- __finalize_[spec|body]
2082 Add_Str_To_Name_Buffer
("__finalize_");
2085 Add_Str_To_Name_Buffer
("spec");
2087 Add_Str_To_Name_Buffer
("body");
2091 end New_Finalizer_Name
;
2093 --------------------------
2094 -- Process_Declarations --
2095 --------------------------
2097 procedure Process_Declarations
2099 Preprocess
: Boolean := False;
2100 Top_Level
: Boolean := False)
2105 Obj_Typ
: Entity_Id
;
2106 Pack_Id
: Entity_Id
;
2110 Old_Counter_Val
: Nat
;
2111 -- This variable is used to determine whether a nested package or
2112 -- instance contains at least one controlled object.
2114 procedure Process_Package_Body
(Decl
: Node_Id
);
2115 -- Process an N_Package_Body node
2117 procedure Processing_Actions
2118 (Has_No_Init
: Boolean := False;
2119 Is_Protected
: Boolean := False);
2120 -- Depending on the mode of operation of Process_Declarations, either
2121 -- increment the controlled object counter, set the controlled object
2122 -- flag and store the last top level construct or process the current
2123 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2124 -- the current declaration may not have initialization proc(s). Flag
2125 -- Is_Protected should be set when the current declaration denotes a
2126 -- simple protected object.
2128 --------------------------
2129 -- Process_Package_Body --
2130 --------------------------
2132 procedure Process_Package_Body
(Decl
: Node_Id
) is
2134 -- Do not inspect an ignored Ghost package body because all
2135 -- code found within will not appear in the final tree.
2137 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2140 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
then
2141 Old_Counter_Val
:= Counter_Val
;
2142 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2144 -- The nested package body is the last construct to contain
2145 -- a controlled object.
2149 and then No
(Last_Top_Level_Ctrl_Construct
)
2150 and then Counter_Val
> Old_Counter_Val
2152 Last_Top_Level_Ctrl_Construct
:= Decl
;
2155 end Process_Package_Body
;
2157 ------------------------
2158 -- Processing_Actions --
2159 ------------------------
2161 procedure Processing_Actions
2162 (Has_No_Init
: Boolean := False;
2163 Is_Protected
: Boolean := False)
2166 -- Library-level tagged type
2168 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2170 Has_Tagged_Types
:= True;
2172 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2173 Last_Top_Level_Ctrl_Construct
:= Decl
;
2176 -- Unregister tagged type, unless No_Tagged_Type_Registration
2179 elsif not Restriction_Active
(No_Tagged_Type_Registration
) then
2180 Process_Tagged_Type_Declaration
(Decl
);
2183 -- Controlled object declaration
2187 Counter_Val
:= Counter_Val
+ 1;
2188 Has_Ctrl_Objs
:= True;
2190 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2191 Last_Top_Level_Ctrl_Construct
:= Decl
;
2195 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2198 end Processing_Actions
;
2200 -- Start of processing for Process_Declarations
2203 if Is_Empty_List
(Decls
) then
2207 -- Process all declarations in reverse order
2209 Decl
:= Last_Non_Pragma
(Decls
);
2210 while Present
(Decl
) loop
2211 -- Library-level tagged types
2213 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2214 Typ
:= Defining_Identifier
(Decl
);
2216 -- Ignored Ghost types do not need any cleanup actions because
2217 -- they will not appear in the final tree.
2219 if Is_Ignored_Ghost_Entity
(Typ
) then
2222 elsif Is_Tagged_Type
(Typ
)
2223 and then Is_Library_Level_Entity
(Typ
)
2224 and then Convention
(Typ
) = Convention_Ada
2225 and then Present
(Access_Disp_Table
(Typ
))
2226 and then not Is_Abstract_Type
(Typ
)
2227 and then not No_Run_Time_Mode
2228 and then not Restriction_Active
(No_Tagged_Type_Registration
)
2229 and then RTE_Available
(RE_Register_Tag
)
2234 -- Regular object declarations
2236 elsif Nkind
(Decl
) = N_Object_Declaration
then
2237 Obj_Id
:= Defining_Identifier
(Decl
);
2238 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2239 Expr
:= Expression
(Decl
);
2241 -- Bypass any form of processing for objects which have their
2242 -- finalization disabled. This applies only to objects at the
2245 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2248 -- Finalization of transient objects are treated separately in
2249 -- order to handle sensitive cases. These include:
2251 -- * Aggregate expansion
2252 -- * If, case, and expression with actions expansion
2253 -- * Transient scopes
2255 -- If one of those contexts has marked the transient object as
2256 -- ignored, do not generate finalization actions for it.
2258 elsif Is_Finalized_Transient
(Obj_Id
)
2259 or else Is_Ignored_Transient
(Obj_Id
)
2263 -- Ignored Ghost objects do not need any cleanup actions
2264 -- because they will not appear in the final tree.
2266 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2269 -- The object is of the form:
2270 -- Obj : [constant] Typ [:= Expr];
2272 -- Do not process the incomplete view of a deferred constant.
2273 -- Note that an object initialized by means of a BIP function
2274 -- call may appear as a deferred constant after expansion
2275 -- activities. These kinds of objects must be finalized.
2277 elsif not Is_Imported
(Obj_Id
)
2278 and then Needs_Finalization
(Obj_Typ
)
2279 and then not (Ekind
(Obj_Id
) = E_Constant
2280 and then not Has_Completion
(Obj_Id
)
2281 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2285 -- The object is of the form:
2286 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2288 -- Obj : Access_Typ :=
2289 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2291 elsif Is_Access_Type
(Obj_Typ
)
2292 and then Needs_Finalization
2293 (Available_View
(Designated_Type
(Obj_Typ
)))
2294 and then Present
(Expr
)
2296 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2298 (Is_Non_BIP_Func_Call
(Expr
)
2299 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2301 Processing_Actions
(Has_No_Init
=> True);
2303 -- Processing for "hook" objects generated for transient
2304 -- objects declared inside an Expression_With_Actions.
2306 elsif Is_Access_Type
(Obj_Typ
)
2307 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2308 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2309 N_Object_Declaration
2311 Processing_Actions
(Has_No_Init
=> True);
2313 -- Process intermediate results of an if expression with one
2314 -- of the alternatives using a controlled function call.
2316 elsif Is_Access_Type
(Obj_Typ
)
2317 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2318 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2319 N_Defining_Identifier
2320 and then Present
(Expr
)
2321 and then Nkind
(Expr
) = N_Null
2323 Processing_Actions
(Has_No_Init
=> True);
2325 -- Simple protected objects which use type System.Tasking.
2326 -- Protected_Objects.Protection to manage their locks should
2327 -- be treated as controlled since they require manual cleanup.
2328 -- The only exception is illustrated in the following example:
2331 -- type Ctrl is new Controlled ...
2332 -- procedure Finalize (Obj : in out Ctrl);
2336 -- package body Pkg is
2337 -- protected Prot is
2338 -- procedure Do_Something (Obj : in out Ctrl);
2341 -- protected body Prot is
2342 -- procedure Do_Something (Obj : in out Ctrl) is ...
2345 -- procedure Finalize (Obj : in out Ctrl) is
2347 -- Prot.Do_Something (Obj);
2351 -- Since for the most part entities in package bodies depend on
2352 -- those in package specs, Prot's lock should be cleaned up
2353 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2354 -- This act however attempts to invoke Do_Something and fails
2355 -- because the lock has disappeared.
2357 elsif Ekind
(Obj_Id
) = E_Variable
2358 and then not In_Library_Level_Package_Body
(Obj_Id
)
2359 and then Has_Simple_Protected_Object
(Obj_Typ
)
2361 Processing_Actions
(Is_Protected
=> True);
2364 -- Specific cases of object renamings
2366 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2367 Obj_Id
:= Defining_Identifier
(Decl
);
2368 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2370 -- Bypass any form of processing for objects which have their
2371 -- finalization disabled. This applies only to objects at the
2374 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2377 -- Ignored Ghost object renamings do not need any cleanup
2378 -- actions because they will not appear in the final tree.
2380 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2383 -- Return object of extended return statements. This case is
2384 -- recognized and marked by the expansion of extended return
2385 -- statements (see Expand_N_Extended_Return_Statement).
2387 elsif Needs_Finalization
(Obj_Typ
)
2388 and then Is_Return_Object
(Obj_Id
)
2389 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2391 Processing_Actions
(Has_No_Init
=> True);
2394 -- Inspect the freeze node of an access-to-controlled type and
2395 -- look for a delayed finalization master. This case arises when
2396 -- the freeze actions are inserted at a later time than the
2397 -- expansion of the context. Since Build_Finalizer is never called
2398 -- on a single construct twice, the master will be ultimately
2399 -- left out and never finalized. This is also needed for freeze
2400 -- actions of designated types themselves, since in some cases the
2401 -- finalization master is associated with a designated type's
2402 -- freeze node rather than that of the access type (see handling
2403 -- for freeze actions in Build_Finalization_Master).
2405 elsif Nkind
(Decl
) = N_Freeze_Entity
2406 and then Present
(Actions
(Decl
))
2408 Typ
:= Entity
(Decl
);
2410 -- Freeze nodes for ignored Ghost types do not need cleanup
2411 -- actions because they will never appear in the final tree.
2413 if Is_Ignored_Ghost_Entity
(Typ
) then
2416 elsif (Is_Access_Object_Type
(Typ
)
2417 and then Needs_Finalization
2418 (Available_View
(Designated_Type
(Typ
))))
2419 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2421 Old_Counter_Val
:= Counter_Val
;
2423 -- Freeze nodes are considered to be identical to packages
2424 -- and blocks in terms of nesting. The difference is that
2425 -- a finalization master created inside the freeze node is
2426 -- at the same nesting level as the node itself.
2428 Process_Declarations
(Actions
(Decl
), Preprocess
);
2430 -- The freeze node contains a finalization master
2434 and then No
(Last_Top_Level_Ctrl_Construct
)
2435 and then Counter_Val
> Old_Counter_Val
2437 Last_Top_Level_Ctrl_Construct
:= Decl
;
2441 -- Nested package declarations, avoid generics
2443 elsif Nkind
(Decl
) = N_Package_Declaration
then
2444 Pack_Id
:= Defining_Entity
(Decl
);
2445 Spec
:= Specification
(Decl
);
2447 -- Do not inspect an ignored Ghost package because all code
2448 -- found within will not appear in the final tree.
2450 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2453 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2454 Old_Counter_Val
:= Counter_Val
;
2455 Process_Declarations
2456 (Private_Declarations
(Spec
), Preprocess
);
2457 Process_Declarations
2458 (Visible_Declarations
(Spec
), Preprocess
);
2460 -- Either the visible or the private declarations contain a
2461 -- controlled object. The nested package declaration is the
2462 -- last such construct.
2466 and then No
(Last_Top_Level_Ctrl_Construct
)
2467 and then Counter_Val
> Old_Counter_Val
2469 Last_Top_Level_Ctrl_Construct
:= Decl
;
2473 -- Nested package bodies, avoid generics
2475 elsif Nkind
(Decl
) = N_Package_Body
then
2476 Process_Package_Body
(Decl
);
2478 elsif Nkind
(Decl
) = N_Package_Body_Stub
2479 and then Present
(Library_Unit
(Decl
))
2481 Process_Package_Body
(Proper_Body
(Unit
(Library_Unit
(Decl
))));
2483 -- Handle a rare case caused by a controlled transient object
2484 -- created as part of a record init proc. The variable is wrapped
2485 -- in a block, but the block is not associated with a transient
2488 elsif Nkind
(Decl
) = N_Block_Statement
2489 and then Inside_Init_Proc
2491 Old_Counter_Val
:= Counter_Val
;
2493 if Present
(Handled_Statement_Sequence
(Decl
)) then
2494 Process_Declarations
2495 (Statements
(Handled_Statement_Sequence
(Decl
)),
2499 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2501 -- Either the declaration or statement list of the block has a
2502 -- controlled object.
2506 and then No
(Last_Top_Level_Ctrl_Construct
)
2507 and then Counter_Val
> Old_Counter_Val
2509 Last_Top_Level_Ctrl_Construct
:= Decl
;
2512 -- Handle the case where the original context has been wrapped in
2513 -- a block to avoid interference between exception handlers and
2514 -- At_End handlers. Treat the block as transparent and process its
2517 elsif Nkind
(Decl
) = N_Block_Statement
2518 and then Is_Finalization_Wrapper
(Decl
)
2520 if Present
(Handled_Statement_Sequence
(Decl
)) then
2521 Process_Declarations
2522 (Statements
(Handled_Statement_Sequence
(Decl
)),
2526 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2529 Prev_Non_Pragma
(Decl
);
2531 end Process_Declarations
;
2533 --------------------------------
2534 -- Process_Object_Declaration --
2535 --------------------------------
2537 procedure Process_Object_Declaration
2539 Has_No_Init
: Boolean := False;
2540 Is_Protected
: Boolean := False)
2542 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2543 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2545 Init_Typ
: Entity_Id
;
2546 -- The initialization type of the related object declaration. Note
2547 -- that this is not necessarily the same type as Obj_Typ because of
2548 -- possible type derivations.
2550 Obj_Typ
: Entity_Id
;
2551 -- The type of the related object declaration
2553 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2554 -- Func_Id denotes a build-in-place function. Generate the following
2557 -- if BIPallocfrom > Secondary_Stack'Pos
2558 -- and then BIPfinalizationmaster /= null
2561 -- type Ptr_Typ is access Obj_Typ;
2562 -- for Ptr_Typ'Storage_Pool
2563 -- use Base_Pool (BIPfinalizationmaster);
2565 -- Free (Ptr_Typ (Temp));
2569 -- Obj_Typ is the type of the current object, Temp is the original
2570 -- allocation which Obj_Id renames.
2572 procedure Find_Last_Init
2573 (Last_Init
: out Node_Id
;
2574 Body_Insert
: out Node_Id
);
2575 -- Find the last initialization call related to object declaration
2576 -- Decl. Last_Init denotes the last initialization call which follows
2577 -- Decl. Body_Insert denotes a node where the finalizer body could be
2578 -- potentially inserted after (if blocks are involved).
2580 -----------------------------
2581 -- Build_BIP_Cleanup_Stmts --
2582 -----------------------------
2584 function Build_BIP_Cleanup_Stmts
2585 (Func_Id
: Entity_Id
) return Node_Id
2587 Decls
: constant List_Id
:= New_List
;
2588 Fin_Mas_Id
: constant Entity_Id
:=
2589 Build_In_Place_Formal
2590 (Func_Id
, BIP_Finalization_Master
);
2591 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2592 Temp_Id
: constant Entity_Id
:=
2593 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2597 Free_Stmt
: Node_Id
;
2598 Pool_Id
: Entity_Id
;
2599 Ptr_Typ
: Entity_Id
;
2603 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2605 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2608 Make_Object_Renaming_Declaration
(Loc
,
2609 Defining_Identifier
=> Pool_Id
,
2611 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2613 Make_Explicit_Dereference
(Loc
,
2615 Make_Function_Call
(Loc
,
2617 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2618 Parameter_Associations
=> New_List
(
2619 Make_Explicit_Dereference
(Loc
,
2621 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2623 -- Create an access type which uses the storage pool of the
2624 -- caller's finalization master.
2627 -- type Ptr_Typ is access Func_Typ;
2629 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2632 Make_Full_Type_Declaration
(Loc
,
2633 Defining_Identifier
=> Ptr_Typ
,
2635 Make_Access_To_Object_Definition
(Loc
,
2636 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2638 -- Perform minor decoration in order to set the master and the
2639 -- storage pool attributes.
2641 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2642 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2643 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2645 if Debug_Generated_Code
then
2646 Set_Debug_Info_Needed
(Pool_Id
);
2649 -- Create an explicit free statement. Note that the free uses the
2650 -- caller's pool expressed as a renaming.
2653 Make_Free_Statement
(Loc
,
2655 Unchecked_Convert_To
(Ptr_Typ
,
2656 New_Occurrence_Of
(Temp_Id
, Loc
)));
2658 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2660 -- Create a block to house the dummy type and the instantiation as
2661 -- well as to perform the cleanup the temporary.
2667 -- Free (Ptr_Typ (Temp_Id));
2671 Make_Block_Statement
(Loc
,
2672 Declarations
=> Decls
,
2673 Handled_Statement_Sequence
=>
2674 Make_Handled_Sequence_Of_Statements
(Loc
,
2675 Statements
=> New_List
(Free_Stmt
)));
2678 -- if BIPfinalizationmaster /= null then
2682 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2683 Right_Opnd
=> Make_Null
(Loc
));
2685 -- For unconstrained or tagged results, escalate the condition to
2686 -- include the allocation format. Generate:
2688 -- if BIPallocform > Secondary_Stack'Pos
2689 -- and then BIPfinalizationmaster /= null
2692 if Needs_BIP_Alloc_Form
(Func_Id
) then
2694 Alloc
: constant Entity_Id
:=
2695 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2701 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2703 Make_Integer_Literal
(Loc
,
2705 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2707 Right_Opnd
=> Cond
);
2717 Make_If_Statement
(Loc
,
2719 Then_Statements
=> New_List
(Free_Blk
));
2720 end Build_BIP_Cleanup_Stmts
;
2722 --------------------
2723 -- Find_Last_Init --
2724 --------------------
2726 procedure Find_Last_Init
2727 (Last_Init
: out Node_Id
;
2728 Body_Insert
: out Node_Id
)
2730 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2731 -- Find the last initialization call within the statements of
2734 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2735 -- Determine whether node N denotes one of the initialization
2736 -- procedures of types Init_Typ or Obj_Typ.
2738 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2739 -- Obtain the next statement which follows list member Stmt while
2740 -- ignoring artifacts related to access-before-elaboration checks.
2742 -----------------------------
2743 -- Find_Last_Init_In_Block --
2744 -----------------------------
2746 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2747 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2751 -- Examine the individual statements of the block in reverse to
2752 -- locate the last initialization call.
2754 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2755 Stmt
:= Last
(Statements
(HSS
));
2756 while Present
(Stmt
) loop
2758 -- Peek inside nested blocks in case aborts are allowed
2760 if Nkind
(Stmt
) = N_Block_Statement
then
2761 return Find_Last_Init_In_Block
(Stmt
);
2763 elsif Is_Init_Call
(Stmt
) then
2772 end Find_Last_Init_In_Block
;
2778 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2779 function Is_Init_Proc_Of
2780 (Subp_Id
: Entity_Id
;
2781 Typ
: Entity_Id
) return Boolean;
2782 -- Determine whether subprogram Subp_Id is a valid init proc of
2785 ---------------------
2786 -- Is_Init_Proc_Of --
2787 ---------------------
2789 function Is_Init_Proc_Of
2790 (Subp_Id
: Entity_Id
;
2791 Typ
: Entity_Id
) return Boolean
2793 Deep_Init
: Entity_Id
:= Empty
;
2794 Prim_Init
: Entity_Id
:= Empty
;
2795 Type_Init
: Entity_Id
:= Empty
;
2798 -- Obtain all possible initialization routines of the
2799 -- related type and try to match the subprogram entity
2800 -- against one of them.
2804 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2806 -- Primitive Initialize
2808 if Is_Controlled
(Typ
) then
2809 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2811 if Present
(Prim_Init
) then
2812 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2816 -- Type initialization routine
2818 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2819 Type_Init
:= Base_Init_Proc
(Typ
);
2823 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2825 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2827 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2828 end Is_Init_Proc_Of
;
2832 Call_Id
: Entity_Id
;
2834 -- Start of processing for Is_Init_Call
2837 if Nkind
(N
) = N_Procedure_Call_Statement
2838 and then Nkind
(Name
(N
)) = N_Identifier
2840 Call_Id
:= Entity
(Name
(N
));
2842 -- Consider both the type of the object declaration and its
2843 -- related initialization type.
2846 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2848 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2854 -----------------------------
2855 -- Next_Suitable_Statement --
2856 -----------------------------
2858 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2862 -- Skip call markers and Program_Error raises installed by the
2865 Result
:= Next
(Stmt
);
2866 while Present
(Result
) loop
2867 exit when Nkind
(Result
) not in
2868 N_Call_Marker | N_Raise_Program_Error
;
2874 end Next_Suitable_Statement
;
2882 Deep_Init_Found
: Boolean := False;
2883 -- A flag set when a call to [Deep_]Initialize has been found
2885 -- Start of processing for Find_Last_Init
2889 Body_Insert
:= Empty
;
2891 -- Object renamings and objects associated with controlled
2892 -- function results do not require initialization.
2898 Stmt
:= Next_Suitable_Statement
(Decl
);
2900 -- For an object with suppressed initialization, we check whether
2901 -- there is in fact no initialization expression. If there is not,
2902 -- then this is an object declaration that has been turned into a
2903 -- different object declaration that calls the build-in-place
2904 -- function in a 'Reference attribute, as in "F(...)'Reference".
2905 -- We search for that later object declaration, so that the
2906 -- Inc_Decl will be inserted after the call. Otherwise, if the
2907 -- call raises an exception, we will finalize the (uninitialized)
2908 -- object, which is wrong.
2910 if No_Initialization
(Decl
) then
2911 if No
(Expression
(Last_Init
)) then
2914 exit when No
(Last_Init
);
2915 exit when Nkind
(Last_Init
) = N_Object_Declaration
2916 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2917 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2919 and then Is_Expanded_Build_In_Place_Call
2920 (Prefix
(Expression
(Last_Init
)));
2926 -- If the initialization is in the declaration, we're done, so
2927 -- early return if we have no more statements or they have been
2928 -- rewritten, which means that they were in the source code.
2930 elsif No
(Stmt
) or else Original_Node
(Stmt
) /= Stmt
then
2933 -- In all other cases the initialization calls follow the related
2934 -- object. The general structure of object initialization built by
2935 -- routine Default_Initialize_Object is as follows:
2937 -- [begin -- aborts allowed
2939 -- Type_Init_Proc (Obj);
2940 -- [begin] -- exceptions allowed
2941 -- Deep_Initialize (Obj);
2942 -- [exception -- exceptions allowed
2944 -- Deep_Finalize (Obj, Self => False);
2947 -- [at end -- aborts allowed
2951 -- When aborts are allowed, the initialization calls are housed
2954 elsif Nkind
(Stmt
) = N_Block_Statement
then
2955 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2956 Body_Insert
:= Stmt
;
2958 -- Otherwise the initialization calls follow the related object
2961 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2963 -- Check for an optional call to Deep_Initialize which may
2964 -- appear within a block depending on whether the object has
2965 -- controlled components.
2967 if Present
(Stmt_2
) then
2968 if Nkind
(Stmt_2
) = N_Block_Statement
then
2969 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2971 if Present
(Call
) then
2972 Deep_Init_Found
:= True;
2974 Body_Insert
:= Stmt_2
;
2977 elsif Is_Init_Call
(Stmt_2
) then
2978 Deep_Init_Found
:= True;
2979 Last_Init
:= Stmt_2
;
2980 Body_Insert
:= Last_Init
;
2984 -- If the object lacks a call to Deep_Initialize, then it must
2985 -- have a call to its related type init proc.
2987 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2989 Body_Insert
:= Last_Init
;
2997 Count_Ins
: Node_Id
;
2999 Fin_Stmts
: List_Id
:= No_List
;
3002 Label_Id
: Entity_Id
;
3005 -- Start of processing for Process_Object_Declaration
3008 -- Handle the object type and the reference to the object. Note
3009 -- that objects having simple protected components must retain
3010 -- their original form for the processing below to work.
3012 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
3013 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
3016 if Is_Access_Type
(Obj_Typ
) then
3017 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
3018 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
3020 elsif Is_Concurrent_Type
(Obj_Typ
)
3021 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
3022 and then not Is_Protected
3024 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
3025 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3027 elsif Is_Private_Type
(Obj_Typ
)
3028 and then Present
(Full_View
(Obj_Typ
))
3030 Obj_Typ
:= Full_View
(Obj_Typ
);
3031 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3033 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3034 Obj_Typ
:= Base_Type
(Obj_Typ
);
3035 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3042 Set_Etype
(Obj_Ref
, Obj_Typ
);
3044 -- Handle the initialization type of the object declaration
3046 Init_Typ
:= Obj_Typ
;
3048 if Is_Private_Type
(Init_Typ
)
3049 and then Present
(Full_View
(Init_Typ
))
3051 Init_Typ
:= Full_View
(Init_Typ
);
3053 elsif Is_Untagged_Derivation
(Init_Typ
) then
3054 Init_Typ
:= Root_Type
(Init_Typ
);
3061 -- Set a new value for the state counter and insert the statement
3062 -- after the object declaration. Generate:
3064 -- Counter := <value>;
3067 Make_Assignment_Statement
(Loc
,
3068 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3069 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3071 -- Insert the counter after all initialization has been done. The
3072 -- place of insertion depends on the context.
3074 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3076 -- The object is initialized by a build-in-place function call.
3077 -- The counter insertion point is after the function call.
3079 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3080 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3083 -- The object is initialized by an aggregate. Insert the counter
3084 -- after the last aggregate assignment.
3086 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3087 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3090 -- In all other cases the counter is inserted after the last call
3091 -- to either [Deep_]Initialize or the type-specific init proc.
3094 Find_Last_Init
(Count_Ins
, Body_Ins
);
3097 -- In all other cases the counter is inserted after the last call to
3098 -- either [Deep_]Initialize or the type-specific init proc.
3101 Find_Last_Init
(Count_Ins
, Body_Ins
);
3104 -- If the Initialize function is null or trivial, the call will have
3105 -- been replaced with a null statement, in which case place counter
3106 -- declaration after object declaration itself.
3108 if No
(Count_Ins
) then
3112 Insert_After
(Count_Ins
, Inc_Decl
);
3115 -- If the current declaration is the last in the list, the finalizer
3116 -- body needs to be inserted after the set counter statement for the
3117 -- current object declaration. This is complicated by the fact that
3118 -- the set counter statement may appear in abort deferred block. In
3119 -- that case, the proper insertion place is after the block.
3121 if No
(Finalizer_Insert_Nod
) then
3123 -- Insertion after an abort deferred block
3125 if Present
(Body_Ins
) then
3126 Finalizer_Insert_Nod
:= Body_Ins
;
3128 Finalizer_Insert_Nod
:= Inc_Decl
;
3132 -- Create the associated label with this object, generate:
3134 -- L<counter> : label;
3137 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3139 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3140 Label
:= Make_Label
(Loc
, Label_Id
);
3142 Prepend_To
(Finalizer_Decls
,
3143 Make_Implicit_Label_Declaration
(Loc
,
3144 Defining_Identifier
=> Entity
(Label_Id
),
3145 Label_Construct
=> Label
));
3147 -- Create the associated jump with this object, generate:
3149 -- when <counter> =>
3152 Prepend_To
(Jump_Alts
,
3153 Make_Case_Statement_Alternative
(Loc
,
3154 Discrete_Choices
=> New_List
(
3155 Make_Integer_Literal
(Loc
, Counter_Val
)),
3156 Statements
=> New_List
(
3157 Make_Goto_Statement
(Loc
,
3158 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3160 -- Insert the jump destination, generate:
3164 Append_To
(Finalizer_Stmts
, Label
);
3166 -- Disable warnings on Obj_Id. This works around an issue where GCC
3167 -- is not able to detect that Obj_Id is protected by a counter and
3168 -- emits spurious warnings.
3170 if not Comes_From_Source
(Obj_Id
) then
3171 Set_Warnings_Off
(Obj_Id
);
3174 -- Processing for simple protected objects. Such objects require
3175 -- manual finalization of their lock managers.
3177 if Is_Protected
then
3178 if Is_Simple_Protected_Type
(Obj_Typ
) then
3179 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3181 if Present
(Fin_Call
) then
3182 Fin_Stmts
:= New_List
(Fin_Call
);
3185 elsif Is_Array_Type
(Obj_Typ
) then
3186 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3189 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3194 -- System.Tasking.Protected_Objects.Finalize_Protection
3202 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3203 Fin_Stmts
:= New_List
(
3204 Make_Block_Statement
(Loc
,
3205 Handled_Statement_Sequence
=>
3206 Make_Handled_Sequence_Of_Statements
(Loc
,
3207 Statements
=> Fin_Stmts
,
3209 Exception_Handlers
=> New_List
(
3210 Make_Exception_Handler
(Loc
,
3211 Exception_Choices
=> New_List
(
3212 Make_Others_Choice
(Loc
)),
3214 Statements
=> New_List
(
3215 Make_Null_Statement
(Loc
)))))));
3218 -- Processing for regular controlled objects
3223 -- [Deep_]Finalize (Obj);
3226 -- when Id : others =>
3227 -- if not Raised then
3229 -- Save_Occurrence (E, Id);
3238 -- Guard against a missing [Deep_]Finalize when the object type
3239 -- was not properly frozen.
3241 if No
(Fin_Call
) then
3242 Fin_Call
:= Make_Null_Statement
(Loc
);
3245 -- For CodePeer, the exception handlers normally generated here
3246 -- generate complex flowgraphs which result in capacity problems.
3247 -- Omitting these handlers for CodePeer is justified as follows:
3249 -- If a handler is dead, then omitting it is surely ok
3251 -- If a handler is live, then CodePeer should flag the
3252 -- potentially-exception-raising construct that causes it
3253 -- to be live. That is what we are interested in, not what
3254 -- happens after the exception is raised.
3256 if Exceptions_OK
and not CodePeer_Mode
then
3257 Fin_Stmts
:= New_List
(
3258 Make_Block_Statement
(Loc
,
3259 Handled_Statement_Sequence
=>
3260 Make_Handled_Sequence_Of_Statements
(Loc
,
3261 Statements
=> New_List
(Fin_Call
),
3263 Exception_Handlers
=> New_List
(
3264 Build_Exception_Handler
3265 (Finalizer_Data
, For_Package
)))));
3267 -- When exception handlers are prohibited, the finalization call
3268 -- appears unprotected. Any exception raised during finalization
3269 -- will bypass the circuitry which ensures the cleanup of all
3270 -- remaining objects.
3273 Fin_Stmts
:= New_List
(Fin_Call
);
3276 -- If we are dealing with a return object of a build-in-place
3277 -- function, generate the following cleanup statements:
3279 -- if BIPallocfrom > Secondary_Stack'Pos
3280 -- and then BIPfinalizationmaster /= null
3283 -- type Ptr_Typ is access Obj_Typ;
3284 -- for Ptr_Typ'Storage_Pool use
3285 -- Base_Pool (BIPfinalizationmaster.all).all;
3287 -- Free (Ptr_Typ (Temp));
3291 -- The generated code effectively detaches the temporary from the
3292 -- caller finalization master and deallocates the object.
3294 if Is_Return_Object
(Obj_Id
) then
3296 Func_Id
: constant Entity_Id
:=
3297 Return_Applies_To
(Scope
(Obj_Id
));
3300 if Is_Build_In_Place_Function
(Func_Id
)
3301 and then Needs_BIP_Finalization_Master
(Func_Id
)
3303 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3308 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3309 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3311 -- Temporaries created for the purpose of "exporting" a
3312 -- transient object out of an Expression_With_Actions (EWA)
3313 -- need guards. The following illustrates the usage of such
3316 -- Access_Typ : access [all] Obj_Typ;
3317 -- Temp : Access_Typ := null;
3318 -- <Counter> := ...;
3321 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3322 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3324 -- Temp := Ctrl_Trans'Unchecked_Access;
3327 -- The finalization machinery does not process EWA nodes as
3328 -- this may lead to premature finalization of expressions. Note
3329 -- that Temp is marked as being properly initialized regardless
3330 -- of whether the initialization of Ctrl_Trans succeeded. Since
3331 -- a failed initialization may leave Temp with a value of null,
3332 -- add a guard to handle this case:
3334 -- if Obj /= null then
3335 -- <object finalization statements>
3338 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3339 N_Object_Declaration
3341 Fin_Stmts
:= New_List
(
3342 Make_If_Statement
(Loc
,
3345 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3346 Right_Opnd
=> Make_Null
(Loc
)),
3347 Then_Statements
=> Fin_Stmts
));
3349 -- Return objects use a flag to aid in processing their
3350 -- potential finalization when the enclosing function fails
3351 -- to return properly. Generate:
3354 -- <object finalization statements>
3358 Fin_Stmts
:= New_List
(
3359 Make_If_Statement
(Loc
,
3364 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3366 Then_Statements
=> Fin_Stmts
));
3371 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3373 -- Since the declarations are examined in reverse, the state counter
3374 -- must be decremented in order to keep with the true position of
3377 Counter_Val
:= Counter_Val
- 1;
3378 end Process_Object_Declaration
;
3380 -------------------------------------
3381 -- Process_Tagged_Type_Declaration --
3382 -------------------------------------
3384 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3385 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3386 DT_Ptr
: constant Entity_Id
:=
3387 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3390 -- Ada.Tags.Unregister_Tag (<Typ>P);
3392 Append_To
(Tagged_Type_Stmts
,
3393 Make_Procedure_Call_Statement
(Loc
,
3395 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3396 Parameter_Associations
=> New_List
(
3397 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3398 end Process_Tagged_Type_Declaration
;
3400 -- Start of processing for Build_Finalizer
3405 -- Do not perform this expansion in SPARK mode because it is not
3408 if GNATprove_Mode
then
3412 -- Step 1: Extract all lists which may contain controlled objects or
3413 -- library-level tagged types.
3415 if For_Package_Spec
then
3416 Decls
:= Visible_Declarations
(Specification
(N
));
3417 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3419 -- Retrieve the package spec id
3421 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3423 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3424 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3427 -- Accept statement, block, entry body, package body, protected body,
3428 -- subprogram body or task body.
3431 Decls
:= Declarations
(N
);
3432 HSS
:= Handled_Statement_Sequence
(N
);
3434 if Present
(HSS
) then
3435 if Present
(Statements
(HSS
)) then
3436 Stmts
:= Statements
(HSS
);
3439 if Present
(At_End_Proc
(HSS
)) then
3440 Prev_At_End
:= At_End_Proc
(HSS
);
3444 -- Retrieve the package spec id for package bodies
3446 if For_Package_Body
then
3447 Spec_Id
:= Corresponding_Spec
(N
);
3451 -- We do not need to process nested packages since they are handled by
3452 -- the finalizer of the enclosing scope, including at library level.
3453 -- And we do not build two finalizers for an instance without body that
3454 -- is a library unit (see Analyze_Package_Instantiation).
3457 and then (not Is_Compilation_Unit
(Spec_Id
)
3458 or else (Is_Generic_Instance
(Spec_Id
)
3459 and then Package_Instantiation
(Spec_Id
) = N
))
3464 -- Step 2: Object [pre]processing
3468 -- Preprocess the visible declarations now in order to obtain the
3469 -- correct number of controlled object by the time the private
3470 -- declarations are processed.
3472 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3474 -- From all the possible contexts, only package specifications may
3475 -- have private declarations.
3477 if For_Package_Spec
then
3478 Process_Declarations
3479 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3482 -- The current context may lack controlled objects, but require some
3483 -- other form of completion (task termination for instance). In such
3484 -- cases, the finalizer must be created and carry the additional
3487 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3491 -- The preprocessing has determined that the context has controlled
3492 -- objects or library-level tagged types.
3494 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3496 -- Private declarations are processed first in order to preserve
3497 -- possible dependencies between public and private objects.
3499 if For_Package_Spec
then
3500 Process_Declarations
(Priv_Decls
);
3503 Process_Declarations
(Decls
);
3509 -- Preprocess both declarations and statements
3511 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3512 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3514 -- At this point it is known that N has controlled objects. Ensure
3515 -- that N has a declarative list since the finalizer spec will be
3518 if Has_Ctrl_Objs
and then No
(Decls
) then
3519 Set_Declarations
(N
, New_List
);
3520 Decls
:= Declarations
(N
);
3521 Spec_Decls
:= Decls
;
3524 -- The current context may lack controlled objects, but require some
3525 -- other form of completion (task termination for instance). In such
3526 -- cases, the finalizer must be created and carry the additional
3529 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3533 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3534 Process_Declarations
(Stmts
);
3535 Process_Declarations
(Decls
);
3539 -- Step 3: Finalizer creation
3541 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3544 end Build_Finalizer
;
3546 --------------------------
3547 -- Build_Finalizer_Call --
3548 --------------------------
3550 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3552 -- Do not perform this expansion in SPARK mode because we do not create
3553 -- finalizers in the first place.
3555 if GNATprove_Mode
then
3559 -- If the construct to be cleaned up is a protected subprogram body, the
3560 -- finalizer call needs to be associated with the block that wraps the
3561 -- unprotected version of the subprogram. The following illustrates this
3564 -- procedure Prot_SubpP is
3565 -- procedure finalizer is
3567 -- Service_Entries (Prot_Obj);
3574 -- Prot_SubpN (Prot_Obj);
3581 Loc
: constant Source_Ptr
:= Sloc
(N
);
3583 Is_Protected_Subp_Body
: constant Boolean :=
3584 Nkind
(N
) = N_Subprogram_Body
3585 and then Is_Protected_Subprogram_Body
(N
);
3586 -- True if N is the protected version of a subprogram that belongs to
3587 -- a protected type.
3589 HSS
: constant Node_Id
:=
3590 (if Is_Protected_Subp_Body
3591 then Handled_Statement_Sequence
3592 (Last
(Statements
(Handled_Statement_Sequence
(N
))))
3593 else Handled_Statement_Sequence
(N
));
3595 -- We attach the At_End_Proc to the HSS if this is an accept
3596 -- statement or extended return statement. Also in the case of
3597 -- a protected subprogram, because if Service_Entries raises an
3598 -- exception, we do not lock the PO, so we also do not want to
3601 Use_HSS
: constant Boolean :=
3602 Nkind
(N
) in N_Accept_Statement | N_Extended_Return_Statement
3603 or else Is_Protected_Subp_Body
;
3605 At_End_Proc_Bearer
: constant Node_Id
:= (if Use_HSS
then HSS
else N
);
3607 pragma Assert
(No
(At_End_Proc
(At_End_Proc_Bearer
)));
3608 Set_At_End_Proc
(At_End_Proc_Bearer
, New_Occurrence_Of
(Fin_Id
, Loc
));
3609 -- Attach reference to finalizer to tree, for LLVM use
3610 Set_Parent
(At_End_Proc
(At_End_Proc_Bearer
), At_End_Proc_Bearer
);
3611 Analyze
(At_End_Proc
(At_End_Proc_Bearer
));
3612 Expand_At_End_Handler
(At_End_Proc_Bearer
, Empty
);
3614 end Build_Finalizer_Call
;
3616 ---------------------
3617 -- Build_Late_Proc --
3618 ---------------------
3620 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3622 for Final_Prim
in Name_Of
'Range loop
3623 if Name_Of
(Final_Prim
) = Nam
then
3626 (Prim
=> Final_Prim
,
3628 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3631 end Build_Late_Proc
;
3633 -------------------------------
3634 -- Build_Object_Declarations --
3635 -------------------------------
3637 procedure Build_Object_Declarations
3638 (Data
: out Finalization_Exception_Data
;
3641 For_Package
: Boolean := False)
3646 -- This variable captures an unused dummy internal entity, see the
3647 -- comment associated with its use.
3650 pragma Assert
(Decls
/= No_List
);
3652 -- Always set the proper location as it may be needed even when
3653 -- exception propagation is forbidden.
3657 if Restriction_Active
(No_Exception_Propagation
) then
3658 Data
.Abort_Id
:= Empty
;
3660 Data
.Raised_Id
:= Empty
;
3664 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3666 -- In certain scenarios, finalization can be triggered by an abort. If
3667 -- the finalization itself fails and raises an exception, the resulting
3668 -- Program_Error must be supressed and replaced by an abort signal. In
3669 -- order to detect this scenario, save the state of entry into the
3670 -- finalization code.
3672 -- This is not needed for library-level finalizers as they are called by
3673 -- the environment task and cannot be aborted.
3675 if not For_Package
then
3676 if Abort_Allowed
then
3677 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3680 -- Abort_Id : constant Boolean := <A_Expr>;
3683 Make_Object_Declaration
(Loc
,
3684 Defining_Identifier
=> Data
.Abort_Id
,
3685 Constant_Present
=> True,
3686 Object_Definition
=>
3687 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3689 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3691 -- Abort is not required
3694 -- Generate a dummy entity to ensure that the internal symbols are
3695 -- in sync when a unit is compiled with and without aborts.
3697 Dummy
:= Make_Temporary
(Loc
, 'A');
3698 Data
.Abort_Id
:= Empty
;
3701 -- Library-level finalizers
3704 Data
.Abort_Id
:= Empty
;
3707 if Exception_Extra_Info
then
3708 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3711 -- E_Id : Exception_Occurrence;
3714 Make_Object_Declaration
(Loc
,
3715 Defining_Identifier
=> Data
.E_Id
,
3716 Object_Definition
=>
3717 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3718 Set_No_Initialization
(Decl
);
3720 Append_To
(Decls
, Decl
);
3727 -- Raised_Id : Boolean := False;
3730 Make_Object_Declaration
(Loc
,
3731 Defining_Identifier
=> Data
.Raised_Id
,
3732 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3733 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3735 if Debug_Generated_Code
then
3736 Set_Debug_Info_Needed
(Data
.Raised_Id
);
3738 end Build_Object_Declarations
;
3740 ---------------------------
3741 -- Build_Raise_Statement --
3742 ---------------------------
3744 function Build_Raise_Statement
3745 (Data
: Finalization_Exception_Data
) return Node_Id
3751 -- Standard run-time use the specialized routine
3752 -- Raise_From_Controlled_Operation.
3754 if Exception_Extra_Info
3755 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3758 Make_Procedure_Call_Statement
(Data
.Loc
,
3761 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3762 Parameter_Associations
=>
3763 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3765 -- Restricted run-time: exception messages are not supported and hence
3766 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3771 Make_Raise_Program_Error
(Data
.Loc
,
3772 Reason
=> PE_Finalize_Raised_Exception
);
3777 -- Raised_Id and then not Abort_Id
3781 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3783 if Present
(Data
.Abort_Id
) then
3784 Expr
:= Make_And_Then
(Data
.Loc
,
3787 Make_Op_Not
(Data
.Loc
,
3788 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3793 -- if Raised_Id and then not Abort_Id then
3794 -- Raise_From_Controlled_Operation (E_Id);
3796 -- raise Program_Error; -- restricted runtime
3800 Make_If_Statement
(Data
.Loc
,
3802 Then_Statements
=> New_List
(Stmt
));
3803 end Build_Raise_Statement
;
3805 -----------------------------
3806 -- Build_Record_Deep_Procs --
3807 -----------------------------
3809 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3813 (Prim
=> Initialize_Case
,
3815 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3817 if not Is_Limited_View
(Typ
) then
3820 (Prim
=> Adjust_Case
,
3822 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3825 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3826 -- suppressed since these routine will not be used.
3828 if not Restriction_Active
(No_Finalization
) then
3831 (Prim
=> Finalize_Case
,
3833 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3835 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3837 if not CodePeer_Mode
then
3840 (Prim
=> Address_Case
,
3842 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3845 end Build_Record_Deep_Procs
;
3851 function Cleanup_Array
3854 Typ
: Entity_Id
) return List_Id
3856 Loc
: constant Source_Ptr
:= Sloc
(N
);
3857 Index_List
: constant List_Id
:= New_List
;
3859 function Free_Component
return List_Id
;
3860 -- Generate the code to finalize the task or protected subcomponents
3861 -- of a single component of the array.
3863 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3864 -- Generate a loop over one dimension of the array
3866 --------------------
3867 -- Free_Component --
3868 --------------------
3870 function Free_Component
return List_Id
is
3871 Stmts
: List_Id
:= New_List
;
3873 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3876 -- Component type is known to contain tasks or protected objects
3879 Make_Indexed_Component
(Loc
,
3880 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3881 Expressions
=> Index_List
);
3883 Set_Etype
(Tsk
, C_Typ
);
3885 if Is_Task_Type
(C_Typ
) then
3886 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3888 elsif Is_Simple_Protected_Type
(C_Typ
) then
3889 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3891 elsif Is_Record_Type
(C_Typ
) then
3892 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3894 elsif Is_Array_Type
(C_Typ
) then
3895 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3901 ------------------------
3902 -- Free_One_Dimension --
3903 ------------------------
3905 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3909 if Dim
> Number_Dimensions
(Typ
) then
3910 return Free_Component
;
3912 -- Here we generate the required loop
3915 Index
:= Make_Temporary
(Loc
, 'J');
3916 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3919 Make_Implicit_Loop_Statement
(N
,
3920 Identifier
=> Empty
,
3922 Make_Iteration_Scheme
(Loc
,
3923 Loop_Parameter_Specification
=>
3924 Make_Loop_Parameter_Specification
(Loc
,
3925 Defining_Identifier
=> Index
,
3926 Discrete_Subtype_Definition
=>
3927 Make_Attribute_Reference
(Loc
,
3928 Prefix
=> Duplicate_Subexpr
(Obj
),
3929 Attribute_Name
=> Name_Range
,
3930 Expressions
=> New_List
(
3931 Make_Integer_Literal
(Loc
, Dim
))))),
3932 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3934 end Free_One_Dimension
;
3936 -- Start of processing for Cleanup_Array
3939 return Free_One_Dimension
(1);
3942 --------------------
3943 -- Cleanup_Record --
3944 --------------------
3946 function Cleanup_Record
3949 Typ
: Entity_Id
) return List_Id
3951 Loc
: constant Source_Ptr
:= Sloc
(N
);
3952 Stmts
: constant List_Id
:= New_List
;
3953 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3959 if Has_Discriminants
(U_Typ
)
3960 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3961 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3964 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3966 -- For now, do not attempt to free a component that may appear in a
3967 -- variant, and instead issue a warning. Doing this "properly" would
3968 -- require building a case statement and would be quite a mess. Note
3969 -- that the RM only requires that free "work" for the case of a task
3970 -- access value, so already we go way beyond this in that we deal
3971 -- with the array case and non-discriminated record cases.
3974 ("task/protected object in variant record will not be freed??", N
);
3975 return New_List
(Make_Null_Statement
(Loc
));
3978 Comp
:= First_Component
(U_Typ
);
3979 while Present
(Comp
) loop
3980 if Chars
(Comp
) /= Name_uParent
3981 and then (Has_Task
(Etype
(Comp
))
3982 or else Has_Simple_Protected_Object
(Etype
(Comp
)))
3985 Make_Selected_Component
(Loc
,
3986 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3987 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3988 Set_Etype
(Tsk
, Etype
(Comp
));
3990 if Is_Task_Type
(Etype
(Comp
)) then
3991 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3993 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3994 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3996 elsif Is_Record_Type
(Etype
(Comp
)) then
3998 -- Recurse, by generating the prefix of the argument to the
3999 -- eventual cleanup call.
4001 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
4003 elsif Is_Array_Type
(Etype
(Comp
)) then
4004 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
4008 Next_Component
(Comp
);
4014 ------------------------------
4015 -- Cleanup_Protected_Object --
4016 ------------------------------
4018 function Cleanup_Protected_Object
4020 Ref
: Node_Id
) return Node_Id
4022 Loc
: constant Source_Ptr
:= Sloc
(N
);
4025 -- For restricted run-time libraries (Ravenscar), tasks are
4026 -- non-terminating, and protected objects can only appear at library
4027 -- level, so we do not want finalization of protected objects.
4029 if Restricted_Profile
then
4034 Make_Procedure_Call_Statement
(Loc
,
4036 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4037 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4039 end Cleanup_Protected_Object
;
4045 function Cleanup_Task
4047 Ref
: Node_Id
) return Node_Id
4049 Loc
: constant Source_Ptr
:= Sloc
(N
);
4052 -- For restricted run-time libraries (Ravenscar), tasks are
4053 -- non-terminating and they can only appear at library level,
4054 -- so we do not want finalization of task objects.
4056 if Restricted_Profile
then
4061 Make_Procedure_Call_Statement
(Loc
,
4063 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4064 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4068 --------------------------------------
4069 -- Check_Unnesting_Elaboration_Code --
4070 --------------------------------------
4072 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4073 Loc
: constant Source_Ptr
:= Sloc
(N
);
4074 Block_Elab_Proc
: Entity_Id
:= Empty
;
4076 procedure Set_Block_Elab_Proc
;
4077 -- Create a defining identifier for a procedure that will replace
4078 -- a block with nested subprograms (unless it has already been created,
4079 -- in which case this is a no-op).
4081 procedure Set_Block_Elab_Proc
is
4083 if No
(Block_Elab_Proc
) then
4084 Block_Elab_Proc
:= Make_Temporary
(Loc
, 'I');
4086 end Set_Block_Elab_Proc
;
4088 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4089 -- Find entities in the elaboration code of a library package body that
4090 -- contain or represent a subprogram body. A body can appear within a
4091 -- block or a loop or can appear by itself if generated for an object
4092 -- declaration that involves controlled actions. The first such entity
4093 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4094 -- that will be used to reset the scopes of all entities that become
4095 -- local to the new elaboration procedure. This is needed for subsequent
4096 -- unnesting actions, which depend on proper setting of the Scope links
4097 -- to determine the nesting level of each subprogram.
4099 -----------------------
4100 -- Find_Local_Scope --
4101 -----------------------
4103 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4110 while Present
(Stat
) loop
4111 case Nkind
(Stat
) is
4112 when N_Block_Statement
=>
4113 if Present
(Identifier
(Stat
)) then
4114 Id
:= Entity
(Identifier
(Stat
));
4116 -- The Scope of this block needs to be reset to the new
4117 -- procedure if the block contains nested subprograms.
4119 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4120 Set_Block_Elab_Proc
;
4121 Set_Scope
(Id
, Block_Elab_Proc
);
4125 when N_Loop_Statement
=>
4126 Id
:= Entity
(Identifier
(Stat
));
4128 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4129 if Scope
(Id
) = Current_Scope
then
4130 Set_Block_Elab_Proc
;
4131 Set_Scope
(Id
, Block_Elab_Proc
);
4135 -- We traverse the loop's statements as well, which may
4136 -- include other block (etc.) statements that need to have
4137 -- their Scope set to Block_Elab_Proc. (Is this really the
4138 -- case, or do such nested blocks refer to the loop scope
4139 -- rather than the loop's enclosing scope???.)
4141 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4143 when N_If_Statement
=>
4144 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4145 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4147 Node
:= First
(Elsif_Parts
(Stat
));
4148 while Present
(Node
) loop
4149 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4153 when N_Case_Statement
=>
4154 Node
:= First
(Alternatives
(Stat
));
4155 while Present
(Node
) loop
4156 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4160 -- Reset the Scope of a subprogram occurring at the top level
4162 when N_Subprogram_Body
=>
4163 Id
:= Defining_Entity
(Stat
);
4165 Set_Block_Elab_Proc
;
4166 Set_Scope
(Id
, Block_Elab_Proc
);
4174 end Reset_Scopes_To_Block_Elab_Proc
;
4178 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4179 Elab_Body
: Node_Id
;
4180 Elab_Call
: Node_Id
;
4182 -- Start of processing for Check_Unnesting_Elaboration_Code
4185 if Present
(H_Seq
) then
4186 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4188 -- There may be subprograms declared in the exception handlers
4189 -- of the current body.
4191 if Present
(Exception_Handlers
(H_Seq
)) then
4193 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4195 while Present
(Handler
) loop
4196 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4203 if Present
(Block_Elab_Proc
) then
4205 Make_Subprogram_Body
(Loc
,
4207 Make_Procedure_Specification
(Loc
,
4208 Defining_Unit_Name
=> Block_Elab_Proc
),
4209 Declarations
=> New_List
,
4210 Handled_Statement_Sequence
=>
4211 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4214 Make_Procedure_Call_Statement
(Loc
,
4215 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4217 Append_To
(Declarations
(N
), Elab_Body
);
4218 Analyze
(Elab_Body
);
4219 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4221 Set_Handled_Statement_Sequence
(N
,
4222 Make_Handled_Sequence_Of_Statements
(Loc
,
4223 Statements
=> New_List
(Elab_Call
)));
4225 Analyze
(Elab_Call
);
4227 -- Could we reset the scopes of entities associated with the new
4228 -- procedure here via a loop over entities rather than doing it in
4229 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4232 end Check_Unnesting_Elaboration_Code
;
4234 ---------------------------------------
4235 -- Check_Unnesting_In_Decls_Or_Stmts --
4236 ---------------------------------------
4238 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4239 Decl_Or_Stmt
: Node_Id
;
4242 if Unnest_Subprogram_Mode
4243 and then Present
(Decls_Or_Stmts
)
4245 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4246 while Present
(Decl_Or_Stmt
) loop
4247 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4248 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4250 Unnest_Block
(Decl_Or_Stmt
);
4252 -- If-statements may contain subprogram bodies at the outer level
4253 -- of their statement lists, and the subprograms may make up-level
4254 -- references (such as to objects declared in the same statement
4255 -- list). Unlike block and loop cases, however, we don't have an
4256 -- entity on which to test the Contains_Subprogram flag, so
4257 -- Unnest_If_Statement must traverse the statement lists to
4258 -- determine whether there are nested subprograms present.
4260 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4261 Unnest_If_Statement
(Decl_Or_Stmt
);
4263 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4265 Id
: constant Entity_Id
:=
4266 Entity
(Identifier
(Decl_Or_Stmt
));
4269 -- When a top-level loop within declarations of a library
4270 -- package spec or body contains nested subprograms, we wrap
4271 -- it in a procedure to handle possible up-level references
4272 -- to entities associated with the loop (such as loop
4275 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4276 Unnest_Loop
(Decl_Or_Stmt
);
4280 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4281 and then not Modify_Tree_For_C
4283 Check_Unnesting_In_Decls_Or_Stmts
4284 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4285 Check_Unnesting_In_Decls_Or_Stmts
4286 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4288 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4289 and then not Modify_Tree_For_C
4291 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4292 if Present
(Statements
4293 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4295 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4296 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4297 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4301 Next
(Decl_Or_Stmt
);
4304 end Check_Unnesting_In_Decls_Or_Stmts
;
4306 ---------------------------------
4307 -- Check_Unnesting_In_Handlers --
4308 ---------------------------------
4310 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4311 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4314 if Present
(Stmt_Seq
)
4315 and then Present
(Exception_Handlers
(Stmt_Seq
))
4318 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4320 while Present
(Handler
) loop
4321 if Present
(Statements
(Handler
)) then
4322 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4329 end Check_Unnesting_In_Handlers
;
4331 ------------------------------
4332 -- Check_Visibly_Controlled --
4333 ------------------------------
4335 procedure Check_Visibly_Controlled
4336 (Prim
: Final_Primitives
;
4338 E
: in out Entity_Id
;
4339 Cref
: in out Node_Id
)
4341 Parent_Type
: Entity_Id
;
4345 if Is_Derived_Type
(Typ
)
4346 and then Comes_From_Source
(E
)
4347 and then No
(Overridden_Operation
(E
))
4349 -- We know that the explicit operation on the type does not override
4350 -- the inherited operation of the parent, and that the derivation
4351 -- is from a private type that is not visibly controlled.
4353 Parent_Type
:= Etype
(Typ
);
4354 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4356 if Present
(Op
) then
4359 -- Wrap the object to be initialized into the proper
4360 -- unchecked conversion, to be compatible with the operation
4363 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4364 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4366 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4370 end Check_Visibly_Controlled
;
4372 --------------------------
4373 -- Contains_Subprogram --
4374 --------------------------
4376 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4380 E
:= First_Entity
(Blk
);
4382 -- The compiler may generate loops with a declare block containing
4383 -- nested procedures used for finalization. Recursively search for
4384 -- subprograms in such constructs.
4386 if Ekind
(Blk
) = E_Loop
4387 and then Parent_Kind
(Blk
) = N_Loop_Statement
4390 Stmt
: Node_Id
:= First
(Statements
(Parent
(Blk
)));
4392 while Present
(Stmt
) loop
4393 if Nkind
(Stmt
) = N_Block_Statement
then
4395 Id
: constant Entity_Id
:=
4396 Entity
(Identifier
(Stmt
));
4398 if Contains_Subprogram
(Id
) then
4408 while Present
(E
) loop
4409 if Is_Subprogram
(E
) then
4412 elsif Ekind
(E
) in E_Block | E_Loop
4413 and then Contains_Subprogram
(E
)
4422 end Contains_Subprogram
;
4428 function Convert_View
(Proc
: Entity_Id
; Arg
: Node_Id
) return Node_Id
is
4429 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Proc
));
4434 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
4435 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4437 Atyp
:= Etype
(Arg
);
4440 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4441 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4443 elsif Present
(Atyp
)
4444 and then Atyp
/= Ftyp
4445 and then (Is_Private_Type
(Ftyp
)
4446 or else Is_Private_Type
(Atyp
)
4447 or else Is_Private_Type
(Base_Type
(Atyp
)))
4448 and then Implementation_Base_Type
(Atyp
) =
4449 Implementation_Base_Type
(Ftyp
)
4451 return Unchecked_Convert_To
(Ftyp
, Arg
);
4453 -- If the argument is already a conversion, as generated by
4454 -- Make_Init_Call, set the target type to the type of the formal
4455 -- directly, to avoid spurious typing problems.
4457 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
4458 and then not Is_Class_Wide_Type
(Atyp
)
4460 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4461 Set_Etype
(Arg
, Ftyp
);
4464 -- Otherwise, introduce a conversion when the designated object
4465 -- has a type derived from the formal of the controlled routine.
4467 elsif Is_Private_Type
(Ftyp
)
4468 and then Present
(Atyp
)
4469 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4471 return Unchecked_Convert_To
(Ftyp
, Arg
);
4478 -------------------------------
4479 -- Establish_Transient_Scope --
4480 -------------------------------
4482 -- This procedure is called each time a transient block has to be inserted
4483 -- that is to say for each call to a function with unconstrained or tagged
4484 -- result. It creates a new scope on the scope stack in order to enclose
4485 -- all transient variables generated.
4487 procedure Establish_Transient_Scope
4489 Manage_Sec_Stack
: Boolean)
4491 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4492 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4494 function Find_Enclosing_Transient_Scope
return Int
;
4495 -- Examine the scope stack looking for the nearest enclosing transient
4496 -- scope within the innermost enclosing package or subprogram. Return
4497 -- its index in the table or else -1 if no such scope exists.
4499 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
4500 -- Locate a suitable context for arbitrary node N which may need to be
4501 -- serviced by a transient scope. Return Empty if no suitable context
4504 procedure Delegate_Sec_Stack_Management
;
4505 -- Move the management of the secondary stack to the nearest enclosing
4508 procedure Create_Transient_Scope
(Context
: Node_Id
);
4509 -- Place a new scope on the scope stack in order to service construct
4510 -- Context. Context is the node found by Find_Transient_Context. The
4511 -- new scope may also manage the secondary stack.
4513 ----------------------------
4514 -- Create_Transient_Scope --
4515 ----------------------------
4517 procedure Create_Transient_Scope
(Context
: Node_Id
) is
4518 Loc
: constant Source_Ptr
:= Sloc
(N
);
4520 Iter_Loop
: Entity_Id
;
4521 Trans_Scop
: constant Entity_Id
:=
4522 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4525 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4527 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4530 Push_Scope
(Trans_Scop
);
4531 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
4532 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= True;
4534 -- The transient scope must also manage the secondary stack
4536 if Manage_Sec_Stack
then
4537 Set_Uses_Sec_Stack
(Trans_Scop
);
4538 Check_Restriction
(No_Secondary_Stack
, N
);
4540 -- The expansion of iterator loops generates references to objects
4541 -- in order to extract elements from a container:
4543 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4544 -- Obj : <object type> renames Ref.all.Element.all;
4546 -- These references are controlled and returned on the secondary
4547 -- stack. A new reference is created at each iteration of the loop
4548 -- and as a result it must be finalized and the space occupied by
4549 -- it on the secondary stack reclaimed at the end of the current
4552 -- When the context that requires a transient scope is a call to
4553 -- routine Reference, the node to be wrapped is the source object:
4555 -- for Obj of Container loop
4557 -- Routine Wrap_Transient_Declaration however does not generate
4558 -- a physical block as wrapping a declaration will kill it too
4559 -- early. To handle this peculiar case, mark the related iterator
4560 -- loop as requiring the secondary stack. This signals the
4561 -- finalization machinery to manage the secondary stack (see
4562 -- routine Process_Statements_For_Controlled_Objects).
4564 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4566 if Present
(Iter_Loop
) then
4567 Set_Uses_Sec_Stack
(Iter_Loop
);
4571 if Debug_Flag_W
then
4572 Write_Str
(" <Transient>");
4575 end Create_Transient_Scope
;
4577 -----------------------------------
4578 -- Delegate_Sec_Stack_Management --
4579 -----------------------------------
4581 procedure Delegate_Sec_Stack_Management
is
4583 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4585 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4587 -- Prevent the search from going too far or within the scope
4588 -- space of another unit.
4590 if Scope
.Entity
= Standard_Standard
then
4593 -- No transient scope should be encountered during the
4594 -- traversal because Establish_Transient_Scope should have
4595 -- already handled this case.
4597 elsif Scope
.Is_Transient
then
4598 raise Program_Error
;
4600 -- The construct that requires secondary stack management is
4601 -- always enclosed by a package or subprogram scope.
4603 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
4604 Set_Uses_Sec_Stack
(Scope
.Entity
);
4605 Check_Restriction
(No_Secondary_Stack
, N
);
4612 -- At this point no suitable scope was found. This should never occur
4613 -- because a construct is always enclosed by a compilation unit which
4616 pragma Assert
(False);
4617 end Delegate_Sec_Stack_Management
;
4619 ------------------------------------
4620 -- Find_Enclosing_Transient_Scope --
4621 ------------------------------------
4623 function Find_Enclosing_Transient_Scope
return Int
is
4625 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4627 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4629 -- Prevent the search from going too far or within the scope
4630 -- space of another unit.
4632 if Scope
.Entity
= Standard_Standard
4633 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
4637 elsif Scope
.Is_Transient
then
4644 end Find_Enclosing_Transient_Scope
;
4646 ----------------------------
4647 -- Find_Transient_Context --
4648 ----------------------------
4650 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
4651 Curr
: Node_Id
:= N
;
4652 Prev
: Node_Id
:= Empty
;
4655 while Present
(Curr
) loop
4656 case Nkind
(Curr
) is
4660 -- Declarations act as a boundary for a transient scope even if
4661 -- they are not wrapped, see Wrap_Transient_Declaration.
4663 when N_Object_Declaration
4664 | N_Object_Renaming_Declaration
4665 | N_Subtype_Declaration
4671 -- Statements and statement-like constructs act as a boundary
4672 -- for a transient scope.
4674 when N_Accept_Alternative
4675 | N_Attribute_Definition_Clause
4677 | N_Case_Statement_Alternative
4679 | N_Delay_Alternative
4680 | N_Delay_Until_Statement
4681 | N_Delay_Relative_Statement
4682 | N_Discriminant_Association
4684 | N_Entry_Body_Formal_Part
4687 | N_Iteration_Scheme
4688 | N_Terminate_Alternative
4690 pragma Assert
(Present
(Prev
));
4693 when N_Assignment_Statement
=>
4696 when N_Entry_Call_Statement
4697 | N_Procedure_Call_Statement
4699 -- When an entry or procedure call acts as the alternative
4700 -- of a conditional or timed entry call, the proper context
4701 -- is that of the alternative.
4703 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
4704 and then Nkind
(Parent
(Parent
(Curr
))) in
4705 N_Conditional_Entry_Call | N_Timed_Entry_Call
4707 return Parent
(Parent
(Curr
));
4709 -- General case for entry or procedure calls
4717 -- Pragma Check is not a valid transient context in
4718 -- GNATprove mode because the pragma must remain unchanged.
4721 and then Get_Pragma_Id
(Curr
) = Pragma_Check
4725 -- General case for pragmas
4731 when N_Raise_Statement
=>
4734 when N_Simple_Return_Statement
=>
4736 Fun_Id
: constant Entity_Id
:=
4737 Return_Applies_To
(Return_Statement_Entity
(Curr
));
4740 -- A transient context that must manage the secondary
4741 -- stack cannot be a return statement of a function that
4742 -- itself requires secondary stack management, because
4743 -- the function's result would be reclaimed too early.
4744 -- And returns of thunks never require transient scopes.
4746 if (Manage_Sec_Stack
4747 and then Needs_Secondary_Stack
(Etype
(Fun_Id
)))
4748 or else Is_Thunk
(Fun_Id
)
4752 -- General case for return statements
4761 when N_Attribute_Reference
=>
4762 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
4766 -- An Ada 2012 iterator specification is not a valid context
4767 -- because Analyze_Iterator_Specification already employs
4768 -- special processing for it.
4770 when N_Iterator_Specification
=>
4773 when N_Loop_Parameter_Specification
=>
4775 -- An iteration scheme is not a valid context because
4776 -- routine Analyze_Iteration_Scheme already employs
4777 -- special processing.
4779 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
4782 return Parent
(Curr
);
4787 -- The following nodes represent "dummy contexts" which do not
4788 -- need to be wrapped.
4790 when N_Component_Declaration
4791 | N_Discriminant_Specification
4792 | N_Parameter_Specification
4796 -- If the traversal leaves a scope without having been able to
4797 -- find a construct to wrap, something is going wrong, but this
4798 -- can happen in error situations that are not detected yet
4799 -- (such as a dynamic string in a pragma Export).
4801 when N_Block_Statement
4804 | N_Package_Declaration
4818 Curr
:= Parent
(Curr
);
4822 end Find_Transient_Context
;
4824 ------------------------------
4825 -- Is_Package_Or_Subprogram --
4826 ------------------------------
4828 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4830 return Ekind
(Id
) in E_Entry
4835 | E_Subprogram_Body
;
4836 end Is_Package_Or_Subprogram
;
4840 Trans_Idx
: constant Int
:= Find_Enclosing_Transient_Scope
;
4843 -- Start of processing for Establish_Transient_Scope
4846 -- Do not create a new transient scope if there is already an enclosing
4847 -- transient scope within the innermost enclosing package or subprogram.
4849 if Trans_Idx
>= 0 then
4851 -- If the transient scope was requested for purposes of managing the
4852 -- secondary stack, then the existing scope must perform this task,
4853 -- unless the node to be wrapped is a return statement of a function
4854 -- that requires secondary stack management, because the function's
4855 -- result would be reclaimed too early (see Find_Transient_Context).
4857 if Manage_Sec_Stack
then
4859 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Trans_Idx
);
4862 if Nkind
(SE
.Node_To_Be_Wrapped
) /= N_Simple_Return_Statement
4864 Needs_Secondary_Stack
4867 (Return_Statement_Entity
(SE
.Node_To_Be_Wrapped
))))
4869 Set_Uses_Sec_Stack
(SE
.Entity
);
4877 -- Find the construct that must be serviced by a new transient scope, if
4880 Context
:= Find_Transient_Context
(N
);
4882 if Present
(Context
) then
4883 if Nkind
(Context
) = N_Assignment_Statement
then
4885 -- An assignment statement with suppressed controlled semantics
4886 -- does not need a transient scope because finalization is not
4887 -- desirable at this point. Note that No_Ctrl_Actions is also
4888 -- set for non-controlled assignments to suppress dispatching
4891 if No_Ctrl_Actions
(Context
)
4892 and then Needs_Finalization
(Etype
(Name
(Context
)))
4894 -- When a controlled component is initialized by a function
4895 -- call, the result on the secondary stack is always assigned
4896 -- to the component. Signal the nearest suitable scope that it
4897 -- is safe to manage the secondary stack.
4899 if Manage_Sec_Stack
and then Within_Init_Proc
then
4900 Delegate_Sec_Stack_Management
;
4903 -- Otherwise the assignment is a normal transient context and thus
4904 -- requires a transient scope.
4907 Create_Transient_Scope
(Context
);
4913 Create_Transient_Scope
(Context
);
4916 end Establish_Transient_Scope
;
4918 ----------------------------
4919 -- Expand_Cleanup_Actions --
4920 ----------------------------
4922 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4924 (Nkind
(N
) in N_Block_Statement
4928 | N_Extended_Return_Statement
);
4930 Scop
: constant Entity_Id
:= Current_Scope
;
4932 Is_Asynchronous_Call
: constant Boolean :=
4933 Nkind
(N
) = N_Block_Statement
4934 and then Is_Asynchronous_Call_Block
(N
);
4935 Is_Master
: constant Boolean :=
4936 Nkind
(N
) /= N_Extended_Return_Statement
4937 and then Nkind
(N
) /= N_Entry_Body
4938 and then Is_Task_Master
(N
);
4939 Is_Protected_Subp_Body
: constant Boolean :=
4940 Nkind
(N
) = N_Subprogram_Body
4941 and then Is_Protected_Subprogram_Body
(N
);
4942 Is_Task_Allocation
: constant Boolean :=
4943 Nkind
(N
) = N_Block_Statement
4944 and then Is_Task_Allocation_Block
(N
);
4945 Is_Task_Body
: constant Boolean :=
4946 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4948 -- We mark the secondary stack if it is used in this construct, and
4949 -- we're not returning a function result on the secondary stack, except
4950 -- that a build-in-place function that might or might not return on the
4951 -- secondary stack always needs a mark. A run-time test is required in
4952 -- the case where the build-in-place function has a BIP_Alloc extra
4953 -- parameter (see Create_Finalizer).
4955 Needs_Sec_Stack_Mark
: constant Boolean :=
4956 (Uses_Sec_Stack
(Scop
)
4958 not Sec_Stack_Needed_For_Return
(Scop
))
4960 (Is_Build_In_Place_Function
(Scop
)
4961 and then Needs_BIP_Alloc_Form
(Scop
));
4963 Needs_Custom_Cleanup
: constant Boolean :=
4964 Nkind
(N
) = N_Block_Statement
4965 and then Present
(Cleanup_Actions
(N
));
4967 Actions_Required
: constant Boolean :=
4968 Requires_Cleanup_Actions
(N
, True)
4969 or else Is_Asynchronous_Call
4971 or else Is_Protected_Subp_Body
4972 or else Is_Task_Allocation
4973 or else Is_Task_Body
4974 or else Needs_Sec_Stack_Mark
4975 or else Needs_Custom_Cleanup
;
4980 -- Start of processing for Expand_Cleanup_Actions
4983 -- The current construct does not need any form of servicing
4985 if not Actions_Required
then
4989 -- If an extended return statement contains something like
4993 -- where F is a build-in-place function call returning a controlled
4994 -- type, then a temporary object will be implicitly declared as part
4995 -- of the statement list, and this will need cleanup. In such cases,
4998 -- return Result : T := ... do
4999 -- <statements> -- possibly with handlers
5004 -- return Result : T := ... do
5005 -- declare -- no declarations
5007 -- <statements> -- possibly with handlers
5008 -- end; -- no handlers
5011 -- So Expand_Cleanup_Actions will end up being called recursively on the
5014 if Nkind
(N
) = N_Extended_Return_Statement
then
5016 Block
: constant Node_Id
:=
5017 Make_Block_Statement
(Sloc
(N
),
5018 Declarations
=> Empty_List
,
5019 Handled_Statement_Sequence
=>
5020 Handled_Statement_Sequence
(N
));
5022 Set_Handled_Statement_Sequence
(N
,
5023 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
5024 Statements
=> New_List
(Block
)));
5029 -- Analysis of the block did all the work
5034 if Needs_Custom_Cleanup
then
5035 Cln
:= Cleanup_Actions
(N
);
5040 if No
(Declarations
(N
)) then
5041 Set_Declarations
(N
, New_List
);
5045 Decls
: constant List_Id
:= Declarations
(N
);
5047 Mark
: Entity_Id
:= Empty
;
5049 -- If we are generating expanded code for debugging purposes, use the
5050 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5051 -- be updated subsequently to reference the proper line in .dg files.
5052 -- If we are not debugging generated code, use No_Location instead,
5053 -- so that no debug information is generated for the cleanup code.
5054 -- This makes the behavior of the NEXT command in GDB monotonic, and
5055 -- makes the placement of breakpoints more accurate.
5057 if Debug_Generated_Code
then
5063 -- A task activation call has already been built for a task
5064 -- allocation block.
5066 if not Is_Task_Allocation
then
5067 Build_Task_Activation_Call
(N
);
5071 Establish_Task_Master
(N
);
5074 -- If secondary stack is in use, generate:
5076 -- Mnn : constant Mark_Id := SS_Mark;
5078 if Needs_Sec_Stack_Mark
then
5079 Set_Uses_Sec_Stack
(Scop
, False); -- avoid duplicate SS marks
5080 Mark
:= Make_Temporary
(Loc
, 'M');
5083 Mark_Call
: constant Node_Id
:= Build_SS_Mark_Call
(Loc
, Mark
);
5085 Prepend_To
(Decls
, Mark_Call
);
5086 Analyze
(Mark_Call
);
5090 -- Generate finalization calls for all controlled objects appearing
5091 -- in the statements of N. Add context specific cleanup for various
5096 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5099 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5103 if Present
(Fin_Id
) then
5104 Build_Finalizer_Call
(N
, Fin_Id
);
5107 end Expand_Cleanup_Actions
;
5109 ---------------------------
5110 -- Expand_N_Package_Body --
5111 ---------------------------
5113 -- Add call to Activate_Tasks if body is an activator (actual processing
5114 -- is in chapter 9).
5116 -- Generate subprogram descriptor for elaboration routine
5118 -- Encode entity names in package body
5120 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5121 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5122 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5127 -- This is done only for non-generic packages
5129 if Ekind
(Spec_Id
) = E_Package
then
5130 -- Build dispatch tables of library-level tagged types for bodies
5131 -- that are not compilation units (see Analyze_Compilation_Unit),
5132 -- except for instances because they have no N_Compilation_Unit.
5134 if Tagged_Type_Expansion
5135 and then Is_Library_Level_Entity
(Spec_Id
)
5136 and then (not Is_Compilation_Unit
(Spec_Id
)
5137 or else Is_Generic_Instance
(Spec_Id
))
5139 Build_Static_Dispatch_Tables
(N
);
5142 Push_Scope
(Spec_Id
);
5144 Expand_CUDA_Package
(N
);
5146 Build_Task_Activation_Call
(N
);
5148 -- Verify the run-time semantics of pragma Initial_Condition at the
5149 -- end of the body statements.
5151 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5153 -- If this is a library-level package and unnesting is enabled,
5154 -- check for the presence of blocks with nested subprograms occurring
5155 -- in elaboration code, and generate procedures to encapsulate the
5156 -- blocks in case the nested subprograms make up-level references.
5158 if Unnest_Subprogram_Mode
5160 Is_Library_Level_Entity
(Current_Scope
)
5162 Check_Unnesting_Elaboration_Code
(N
);
5163 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5164 Check_Unnesting_In_Handlers
(N
);
5170 Set_Elaboration_Flag
(N
, Spec_Id
);
5171 Set_In_Package_Body
(Spec_Id
, False);
5173 -- Set to encode entity names in package body before gigi is called
5175 Qualify_Entity_Names
(N
);
5177 if Ekind
(Spec_Id
) /= E_Generic_Package
5178 and then not Delay_Cleanups
(Id
)
5182 Clean_Stmts
=> No_List
,
5184 Top_Decls
=> No_List
,
5185 Defer_Abort
=> False,
5188 if Present
(Fin_Id
) then
5189 Set_Finalizer
(Defining_Entity
(N
), Fin_Id
);
5192 end Expand_N_Package_Body
;
5194 ----------------------------------
5195 -- Expand_N_Package_Declaration --
5196 ----------------------------------
5198 -- Add call to Activate_Tasks if there are tasks declared and the package
5199 -- has no body. Note that in Ada 83 this may result in premature activation
5200 -- of some tasks, given that we cannot tell whether a body will eventually
5203 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5204 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5205 Spec
: constant Node_Id
:= Specification
(N
);
5209 No_Body
: Boolean := False;
5210 -- True in the case of a package declaration that is a compilation
5211 -- unit and for which no associated body will be compiled in this
5215 -- Case of a package declaration other than a compilation unit
5217 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5220 -- Case of a compilation unit that does not require a body
5222 elsif not Body_Required
(Parent
(N
))
5223 and then not Unit_Requires_Body
(Id
)
5227 -- Special case of generating calling stubs for a remote call interface
5228 -- package: even though the package declaration requires one, the body
5229 -- won't be processed in this compilation (so any stubs for RACWs
5230 -- declared in the package must be generated here, along with the spec).
5232 elsif Parent
(N
) = Cunit
(Main_Unit
)
5233 and then Is_Remote_Call_Interface
(Id
)
5234 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5239 -- For a nested instance, delay processing until freeze point
5241 if Has_Delayed_Freeze
(Id
)
5242 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5247 -- For a package declaration that implies no associated body, generate
5248 -- task activation call and RACW supporting bodies now (since we won't
5249 -- have a specific separate compilation unit for that).
5254 -- Generate RACW subprogram bodies
5256 if Has_RACW
(Id
) then
5257 Decls
:= Private_Declarations
(Spec
);
5260 Decls
:= Visible_Declarations
(Spec
);
5265 Set_Visible_Declarations
(Spec
, Decls
);
5268 Append_RACW_Bodies
(Decls
, Id
);
5269 Analyze_List
(Decls
);
5272 -- Generate task activation call as last step of elaboration
5274 if Present
(Activation_Chain_Entity
(N
)) then
5275 Build_Task_Activation_Call
(N
);
5278 -- Verify the run-time semantics of pragma Initial_Condition at the
5279 -- end of the private declarations when the package lacks a body.
5281 Expand_Pragma_Initial_Condition
(Id
, N
);
5286 -- Build dispatch tables of library-level tagged types for instances
5287 -- that are not compilation units (see Analyze_Compilation_Unit).
5289 if Tagged_Type_Expansion
5290 and then Is_Library_Level_Entity
(Id
)
5291 and then Is_Generic_Instance
(Id
)
5292 and then not Is_Compilation_Unit
(Id
)
5294 Build_Static_Dispatch_Tables
(N
);
5297 -- Note: it is not necessary to worry about generating a subprogram
5298 -- descriptor, since the only way to get exception handlers into a
5299 -- package spec is to include instantiations, and that would cause
5300 -- generation of subprogram descriptors to be delayed in any case.
5302 -- Set to encode entity names in package spec before gigi is called
5304 Qualify_Entity_Names
(N
);
5306 if Ekind
(Id
) /= E_Generic_Package
5307 and then not Delay_Cleanups
(Id
)
5311 Clean_Stmts
=> No_List
,
5313 Top_Decls
=> No_List
,
5314 Defer_Abort
=> False,
5317 if Present
(Fin_Id
) then
5318 Set_Finalizer
(Id
, Fin_Id
);
5322 -- If this is a library-level package and unnesting is enabled,
5323 -- check for the presence of blocks with nested subprograms occurring
5324 -- in elaboration code, and generate procedures to encapsulate the
5325 -- blocks in case the nested subprograms make up-level references.
5327 if Unnest_Subprogram_Mode
5328 and then Is_Library_Level_Entity
(Current_Scope
)
5330 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
5331 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
5333 end Expand_N_Package_Declaration
;
5335 ---------------------------------
5336 -- Has_Simple_Protected_Object --
5337 ---------------------------------
5339 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5341 if Has_Task
(T
) then
5344 elsif Is_Simple_Protected_Type
(T
) then
5347 elsif Is_Array_Type
(T
) then
5348 return Has_Simple_Protected_Object
(Component_Type
(T
));
5350 elsif Is_Record_Type
(T
) then
5355 Comp
:= First_Component
(T
);
5356 while Present
(Comp
) loop
5357 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5361 Next_Component
(Comp
);
5370 end Has_Simple_Protected_Object
;
5372 ------------------------------------
5373 -- Insert_Actions_In_Scope_Around --
5374 ------------------------------------
5376 procedure Insert_Actions_In_Scope_Around
5379 Manage_SS
: Boolean)
5381 Act_Before
: constant List_Id
:=
5382 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5383 Act_After
: constant List_Id
:=
5384 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5385 Act_Cleanup
: constant List_Id
:=
5386 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5387 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5388 -- Last), but this was incorrect as Process_Transients_In_Scope may
5389 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5391 procedure Process_Transients_In_Scope
5392 (First_Object
: Node_Id
;
5393 Last_Object
: Node_Id
;
5394 Related_Node
: Node_Id
);
5395 -- Find all transient objects in the list First_Object .. Last_Object
5396 -- and generate finalization actions for them. Related_Node denotes the
5397 -- node which created all transient objects.
5399 ---------------------------------
5400 -- Process_Transients_In_Scope --
5401 ---------------------------------
5403 procedure Process_Transients_In_Scope
5404 (First_Object
: Node_Id
;
5405 Last_Object
: Node_Id
;
5406 Related_Node
: Node_Id
)
5408 Must_Hook
: Boolean;
5409 -- Flag denoting whether the context requires transient object
5410 -- export to the outer finalizer.
5412 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5413 -- Return Abandon if arbitrary node denotes a subprogram call
5415 function Has_Subprogram_Call
is
5416 new Traverse_Func
(Is_Subprogram_Call
);
5418 procedure Process_Transient_In_Scope
5419 (Obj_Decl
: Node_Id
;
5420 Blk_Data
: Finalization_Exception_Data
;
5421 Blk_Stmts
: List_Id
);
5422 -- Generate finalization actions for a single transient object
5423 -- denoted by object declaration Obj_Decl. Blk_Data is the
5424 -- exception data of the enclosing block. Blk_Stmts denotes the
5425 -- statements of the enclosing block.
5427 ------------------------
5428 -- Is_Subprogram_Call --
5429 ------------------------
5431 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5433 -- A regular procedure or function call
5435 if Nkind
(N
) in N_Subprogram_Call
then
5440 -- Heavy expansion may relocate function calls outside the related
5441 -- node. Inspect the original node to detect the initial placement
5444 elsif Is_Rewrite_Substitution
(N
) then
5445 return Has_Subprogram_Call
(Original_Node
(N
));
5447 -- Generalized indexing always involves a function call
5449 elsif Nkind
(N
) = N_Indexed_Component
5450 and then Present
(Generalized_Indexing
(N
))
5459 end Is_Subprogram_Call
;
5461 --------------------------------
5462 -- Process_Transient_In_Scope --
5463 --------------------------------
5465 procedure Process_Transient_In_Scope
5466 (Obj_Decl
: Node_Id
;
5467 Blk_Data
: Finalization_Exception_Data
;
5468 Blk_Stmts
: List_Id
)
5470 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5471 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5473 Fin_Stmts
: List_Id
;
5474 Hook_Assign
: Node_Id
;
5475 Hook_Clear
: Node_Id
;
5476 Hook_Decl
: Node_Id
;
5477 Hook_Insert
: Node_Id
;
5481 -- Mark the transient object as successfully processed to avoid
5482 -- double finalization.
5484 Set_Is_Finalized_Transient
(Obj_Id
);
5486 -- Construct all the pieces necessary to hook and finalize the
5487 -- transient object.
5489 Build_Transient_Object_Statements
5490 (Obj_Decl
=> Obj_Decl
,
5491 Fin_Call
=> Fin_Call
,
5492 Hook_Assign
=> Hook_Assign
,
5493 Hook_Clear
=> Hook_Clear
,
5494 Hook_Decl
=> Hook_Decl
,
5495 Ptr_Decl
=> Ptr_Decl
);
5497 -- The context contains at least one subprogram call which may
5498 -- raise an exception. This scenario employs "hooking" to pass
5499 -- transient objects to the enclosing finalizer in case of an
5504 -- Add the access type which provides a reference to the
5505 -- transient object. Generate:
5507 -- type Ptr_Typ is access all Desig_Typ;
5509 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5511 -- Add the temporary which acts as a hook to the transient
5512 -- object. Generate:
5514 -- Hook : Ptr_Typ := null;
5516 Insert_Action
(Obj_Decl
, Hook_Decl
);
5518 -- When the transient object is initialized by an aggregate,
5519 -- the hook must capture the object after the last aggregate
5520 -- assignment takes place. Only then is the object considered
5521 -- fully initialized. Generate:
5523 -- Hook := Ptr_Typ (Obj_Id);
5525 -- Hook := Obj_Id'Unrestricted_Access;
5527 -- Similarly if we have a build in place call: we must
5528 -- initialize Hook only after the call has happened, otherwise
5529 -- Obj_Id will not be initialized yet.
5531 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
5532 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
5533 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5534 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
5535 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
5537 Hook_Insert
:= Obj_Decl
;
5540 -- Otherwise the hook seizes the related object immediately
5543 Hook_Insert
:= Obj_Decl
;
5546 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5549 -- When exception propagation is enabled wrap the hook clear
5550 -- statement and the finalization call into a block to catch
5551 -- potential exceptions raised during finalization. Generate:
5555 -- [Deep_]Finalize (Obj_Ref);
5559 -- if not Raised then
5562 -- (Enn, Get_Current_Excep.all.all);
5566 if Exceptions_OK
then
5567 Fin_Stmts
:= New_List
;
5570 Append_To
(Fin_Stmts
, Hook_Clear
);
5573 Append_To
(Fin_Stmts
, Fin_Call
);
5575 Prepend_To
(Blk_Stmts
,
5576 Make_Block_Statement
(Loc
,
5577 Handled_Statement_Sequence
=>
5578 Make_Handled_Sequence_Of_Statements
(Loc
,
5579 Statements
=> Fin_Stmts
,
5580 Exception_Handlers
=> New_List
(
5581 Build_Exception_Handler
(Blk_Data
)))));
5583 -- Otherwise generate:
5586 -- [Deep_]Finalize (Obj_Ref);
5588 -- Note that the statements are inserted in reverse order to
5589 -- achieve the desired final order outlined above.
5592 Prepend_To
(Blk_Stmts
, Fin_Call
);
5595 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5598 end Process_Transient_In_Scope
;
5602 Built
: Boolean := False;
5603 Blk_Data
: Finalization_Exception_Data
;
5604 Blk_Decl
: Node_Id
:= Empty
;
5605 Blk_Decls
: List_Id
:= No_List
;
5607 Blk_Stmts
: List_Id
:= No_List
;
5608 Loc
: Source_Ptr
:= No_Location
;
5611 -- Start of processing for Process_Transients_In_Scope
5614 -- The expansion performed by this routine is as follows:
5616 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5617 -- Hook_1 : Ptr_Typ_1 := null;
5618 -- Ctrl_Trans_Obj_1 : ...;
5619 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5621 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5622 -- Hook_N : Ptr_Typ_N := null;
5623 -- Ctrl_Trans_Obj_N : ...;
5624 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5627 -- Abrt : constant Boolean := ...;
5628 -- Ex : Exception_Occurrence;
5629 -- Raised : Boolean := False;
5636 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5640 -- if not Raised then
5642 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5647 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5651 -- if not Raised then
5653 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5658 -- if Raised and not Abrt then
5659 -- Raise_From_Controlled_Operation (Ex);
5663 -- Recognize a scenario where the transient context is an object
5664 -- declaration initialized by a build-in-place function call:
5666 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5668 -- The rough expansion of the above is:
5670 -- Temp : ... := Ctrl_Func_Call;
5672 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5674 -- The finalization of any transient object must happen after the
5675 -- build-in-place function call is executed.
5677 if Nkind
(N
) = N_Object_Declaration
5678 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5681 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5683 -- Search the context for at least one subprogram call. If found, the
5684 -- machinery exports all transient objects to the enclosing finalizer
5685 -- due to the possibility of abnormal call termination.
5688 Must_Hook
:= Has_Subprogram_Call
(N
) = Abandon
;
5689 Blk_Ins
:= Last_Object
;
5693 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5696 -- Examine all objects in the list First_Object .. Last_Object
5698 Obj_Decl
:= First_Object
;
5699 while Present
(Obj_Decl
) loop
5700 if Nkind
(Obj_Decl
) = N_Object_Declaration
5701 and then Analyzed
(Obj_Decl
)
5702 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5704 -- Do not process the node to be wrapped since it will be
5705 -- handled by the enclosing finalizer.
5707 and then Obj_Decl
/= Related_Node
5709 Loc
:= Sloc
(Obj_Decl
);
5711 -- Before generating the cleanup code for the first transient
5712 -- object, create a wrapper block which houses all hook clear
5713 -- statements and finalization calls. This wrapper is needed by
5718 Blk_Stmts
:= New_List
;
5721 -- Abrt : constant Boolean := ...;
5722 -- Ex : Exception_Occurrence;
5723 -- Raised : Boolean := False;
5725 if Exceptions_OK
then
5726 Blk_Decls
:= New_List
;
5727 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5731 Make_Block_Statement
(Loc
,
5732 Declarations
=> Blk_Decls
,
5733 Handled_Statement_Sequence
=>
5734 Make_Handled_Sequence_Of_Statements
(Loc
,
5735 Statements
=> Blk_Stmts
));
5738 -- Construct all necessary circuitry to hook and finalize a
5739 -- single transient object.
5741 pragma Assert
(Present
(Blk_Stmts
));
5742 Process_Transient_In_Scope
5743 (Obj_Decl
=> Obj_Decl
,
5744 Blk_Data
=> Blk_Data
,
5745 Blk_Stmts
=> Blk_Stmts
);
5748 -- Terminate the scan after the last object has been processed to
5749 -- avoid touching unrelated code.
5751 if Obj_Decl
= Last_Object
then
5758 -- Complete the decoration of the enclosing finalization block and
5759 -- insert it into the tree.
5761 if Present
(Blk_Decl
) then
5763 pragma Assert
(Present
(Blk_Stmts
));
5764 pragma Assert
(Loc
/= No_Location
);
5766 -- Note that this Abort_Undefer does not require a extra block or
5767 -- an AT_END handler because each finalization exception is caught
5768 -- in its own corresponding finalization block. As a result, the
5769 -- call to Abort_Defer always takes place.
5771 if Abort_Allowed
then
5772 Prepend_To
(Blk_Stmts
,
5773 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5775 Append_To
(Blk_Stmts
,
5776 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5780 -- if Raised and then not Abrt then
5781 -- Raise_From_Controlled_Operation (Ex);
5784 if Exceptions_OK
then
5785 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5788 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5790 end Process_Transients_In_Scope
;
5794 Loc
: constant Source_Ptr
:= Sloc
(N
);
5795 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5796 First_Obj
: Node_Id
;
5798 Mark_Id
: Entity_Id
;
5801 -- Start of processing for Insert_Actions_In_Scope_Around
5804 -- Nothing to do if the scope does not manage the secondary stack or
5805 -- does not contain meaningful actions for insertion.
5808 and then No
(Act_Before
)
5809 and then No
(Act_After
)
5810 and then No
(Act_Cleanup
)
5815 -- If the node to be wrapped is the trigger of an asynchronous select,
5816 -- it is not part of a statement list. The actions must be inserted
5817 -- before the select itself, which is part of some list of statements.
5818 -- Note that the triggering alternative includes the triggering
5819 -- statement and an optional statement list. If the node to be
5820 -- wrapped is part of that list, the normal insertion applies.
5822 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5823 and then not Is_List_Member
(Node_To_Wrap
)
5825 Target
:= Parent
(Parent
(Node_To_Wrap
));
5830 First_Obj
:= Target
;
5833 -- Add all actions associated with a transient scope into the main tree.
5834 -- There are several scenarios here:
5836 -- +--- Before ----+ +----- After ---+
5837 -- 1) First_Obj ....... Target ........ Last_Obj
5839 -- 2) First_Obj ....... Target
5841 -- 3) Target ........ Last_Obj
5843 -- Flag declarations are inserted before the first object
5845 if Present
(Act_Before
) then
5846 First_Obj
:= First
(Act_Before
);
5847 Insert_List_Before
(Target
, Act_Before
);
5850 -- Finalization calls are inserted after the last object
5852 if Present
(Act_After
) then
5853 Last_Obj
:= Last
(Act_After
);
5854 Insert_List_After
(Target
, Act_After
);
5857 -- Mark and release the secondary stack when the context warrants it
5860 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5863 -- Mnn : constant Mark_Id := SS_Mark;
5865 Insert_Before_And_Analyze
5866 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5869 -- SS_Release (Mnn);
5871 Insert_After_And_Analyze
5872 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5875 -- Check for transient objects associated with Target and generate the
5876 -- appropriate finalization actions for them.
5878 Process_Transients_In_Scope
5879 (First_Object
=> First_Obj
,
5880 Last_Object
=> Last_Obj
,
5881 Related_Node
=> Target
);
5883 -- Reset the action lists
5886 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5888 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5892 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5894 end Insert_Actions_In_Scope_Around
;
5896 ------------------------------
5897 -- Is_Simple_Protected_Type --
5898 ------------------------------
5900 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5903 Is_Protected_Type
(T
)
5904 and then not Uses_Lock_Free
(T
)
5905 and then not Has_Entries
(T
)
5906 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5907 end Is_Simple_Protected_Type
;
5909 -----------------------
5910 -- Make_Adjust_Call --
5911 -----------------------
5913 function Make_Adjust_Call
5916 Skip_Self
: Boolean := False) return Node_Id
5918 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5919 Adj_Id
: Entity_Id
:= Empty
;
5926 -- Recover the proper type which contains Deep_Adjust
5928 if Is_Class_Wide_Type
(Typ
) then
5929 Utyp
:= Root_Type
(Typ
);
5934 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5935 Set_Assignment_OK
(Ref
);
5937 -- Deal with untagged derivation of private views
5939 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5940 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5941 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5942 Set_Assignment_OK
(Ref
);
5945 -- When dealing with the completion of a private type, use the base
5948 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5949 pragma Assert
(Is_Private_Type
(Typ
));
5951 Utyp
:= Base_Type
(Utyp
);
5952 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5955 -- The underlying type may not be present due to a missing full view. In
5956 -- this case freezing did not take place and there is no [Deep_]Adjust
5957 -- primitive to call.
5962 elsif Skip_Self
then
5963 if Has_Controlled_Component
(Utyp
) then
5964 if Is_Tagged_Type
(Utyp
) then
5965 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5967 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5971 -- Class-wide types, interfaces and types with controlled components
5973 elsif Is_Class_Wide_Type
(Typ
)
5974 or else Is_Interface
(Typ
)
5975 or else Has_Controlled_Component
(Utyp
)
5977 if Is_Tagged_Type
(Utyp
) then
5978 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5980 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5983 -- Derivations from [Limited_]Controlled
5985 elsif Is_Controlled
(Utyp
) then
5986 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5990 elsif Is_Tagged_Type
(Utyp
) then
5991 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5994 raise Program_Error
;
5997 if Present
(Adj_Id
) then
5999 -- If the object is unanalyzed, set its expected type for use in
6000 -- Convert_View in case an additional conversion is needed.
6003 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
6005 Set_Etype
(Ref
, Typ
);
6008 -- The object reference may need another conversion depending on the
6009 -- type of the formal and that of the actual.
6011 if not Is_Class_Wide_Type
(Typ
) then
6012 Ref
:= Convert_View
(Adj_Id
, Ref
);
6019 Skip_Self
=> Skip_Self
);
6023 end Make_Adjust_Call
;
6031 Proc_Id
: Entity_Id
;
6033 Skip_Self
: Boolean := False) return Node_Id
6035 Params
: constant List_Id
:= New_List
(Param
);
6038 -- Do not apply the controlled action to the object itself by signaling
6039 -- the related routine to avoid self.
6042 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6046 Make_Procedure_Call_Statement
(Loc
,
6047 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6048 Parameter_Associations
=> Params
);
6051 --------------------------
6052 -- Make_Deep_Array_Body --
6053 --------------------------
6055 function Make_Deep_Array_Body
6056 (Prim
: Final_Primitives
;
6057 Typ
: Entity_Id
) return List_Id
6059 function Build_Adjust_Or_Finalize_Statements
6060 (Typ
: Entity_Id
) return List_Id
;
6061 -- Create the statements necessary to adjust or finalize an array of
6062 -- controlled elements. Generate:
6065 -- Abort : constant Boolean := Triggered_By_Abort;
6067 -- Abort : constant Boolean := False; -- no abort
6069 -- E : Exception_Occurrence;
6070 -- Raised : Boolean := False;
6073 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6074 -- ^-- in the finalization case
6076 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6078 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6082 -- if not Raised then
6084 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6091 -- if Raised and then not Abort then
6092 -- Raise_From_Controlled_Operation (E);
6096 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6097 -- Create the statements necessary to initialize an array of controlled
6098 -- elements. Include a mechanism to carry out partial finalization if an
6099 -- exception occurs. Generate:
6102 -- Counter : Integer := 0;
6105 -- for J1 in V'Range (1) loop
6107 -- for JN in V'Range (N) loop
6109 -- [Deep_]Initialize (V (J1, ..., JN));
6111 -- Counter := Counter + 1;
6116 -- Abort : constant Boolean := Triggered_By_Abort;
6118 -- Abort : constant Boolean := False; -- no abort
6119 -- E : Exception_Occurrence;
6120 -- Raised : Boolean := False;
6127 -- V'Length (N) - Counter;
6129 -- for F1 in reverse V'Range (1) loop
6131 -- for FN in reverse V'Range (N) loop
6132 -- if Counter > 0 then
6133 -- Counter := Counter - 1;
6136 -- [Deep_]Finalize (V (F1, ..., FN));
6140 -- if not Raised then
6142 -- Save_Occurrence (E,
6143 -- Get_Current_Excep.all.all);
6152 -- if Raised and then not Abort then
6153 -- Raise_From_Controlled_Operation (E);
6162 function New_References_To
6164 Loc
: Source_Ptr
) return List_Id
;
6165 -- Given a list of defining identifiers, return a list of references to
6166 -- the original identifiers, in the same order as they appear.
6168 -----------------------------------------
6169 -- Build_Adjust_Or_Finalize_Statements --
6170 -----------------------------------------
6172 function Build_Adjust_Or_Finalize_Statements
6173 (Typ
: Entity_Id
) return List_Id
6175 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6176 Index_List
: constant List_Id
:= New_List
;
6177 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6178 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6180 procedure Build_Indexes
;
6181 -- Generate the indexes used in the dimension loops
6187 procedure Build_Indexes
is
6189 -- Generate the following identifiers:
6190 -- Jnn - for initialization
6192 for Dim
in 1 .. Num_Dims
loop
6193 Append_To
(Index_List
,
6194 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6200 Final_Decls
: List_Id
:= No_List
;
6201 Final_Data
: Finalization_Exception_Data
;
6205 Core_Loop
: Node_Id
;
6208 Loop_Id
: Entity_Id
;
6211 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6214 Final_Decls
:= New_List
;
6217 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6220 Make_Indexed_Component
(Loc
,
6221 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6222 Expressions
=> New_References_To
(Index_List
, Loc
));
6223 Set_Etype
(Comp_Ref
, Comp_Typ
);
6226 -- [Deep_]Adjust (V (J1, ..., JN))
6228 if Prim
= Adjust_Case
then
6229 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6232 -- [Deep_]Finalize (V (J1, ..., JN))
6234 else pragma Assert
(Prim
= Finalize_Case
);
6235 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6238 if Present
(Call
) then
6240 -- Generate the block which houses the adjust or finalize call:
6243 -- <adjust or finalize call>
6247 -- if not Raised then
6249 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6253 if Exceptions_OK
then
6255 Make_Block_Statement
(Loc
,
6256 Handled_Statement_Sequence
=>
6257 Make_Handled_Sequence_Of_Statements
(Loc
,
6258 Statements
=> New_List
(Call
),
6259 Exception_Handlers
=> New_List
(
6260 Build_Exception_Handler
(Final_Data
))));
6265 -- Generate the dimension loops starting from the innermost one
6267 -- for Jnn in [reverse] V'Range (Dim) loop
6271 J
:= Last
(Index_List
);
6273 while Present
(J
) and then Dim
> 0 loop
6279 Make_Loop_Statement
(Loc
,
6281 Make_Iteration_Scheme
(Loc
,
6282 Loop_Parameter_Specification
=>
6283 Make_Loop_Parameter_Specification
(Loc
,
6284 Defining_Identifier
=> Loop_Id
,
6285 Discrete_Subtype_Definition
=>
6286 Make_Attribute_Reference
(Loc
,
6287 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6288 Attribute_Name
=> Name_Range
,
6289 Expressions
=> New_List
(
6290 Make_Integer_Literal
(Loc
, Dim
))),
6293 Prim
= Finalize_Case
)),
6295 Statements
=> New_List
(Core_Loop
),
6296 End_Label
=> Empty
);
6301 -- Generate the block which contains the core loop, declarations
6302 -- of the abort flag, the exception occurrence, the raised flag
6303 -- and the conditional raise:
6306 -- Abort : constant Boolean := Triggered_By_Abort;
6308 -- Abort : constant Boolean := False; -- no abort
6310 -- E : Exception_Occurrence;
6311 -- Raised : Boolean := False;
6316 -- if Raised and then not Abort then
6317 -- Raise_From_Controlled_Operation (E);
6321 Stmts
:= New_List
(Core_Loop
);
6323 if Exceptions_OK
then
6324 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6328 Make_Block_Statement
(Loc
,
6329 Declarations
=> Final_Decls
,
6330 Handled_Statement_Sequence
=>
6331 Make_Handled_Sequence_Of_Statements
(Loc
,
6332 Statements
=> Stmts
));
6334 -- Otherwise previous errors or a missing full view may prevent the
6335 -- proper freezing of the component type. If this is the case, there
6336 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6339 Block
:= Make_Null_Statement
(Loc
);
6342 return New_List
(Block
);
6343 end Build_Adjust_Or_Finalize_Statements
;
6345 ---------------------------------
6346 -- Build_Initialize_Statements --
6347 ---------------------------------
6349 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6350 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6351 Final_List
: constant List_Id
:= New_List
;
6352 Index_List
: constant List_Id
:= New_List
;
6353 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6354 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6356 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6357 -- Generate the following assignment:
6358 -- Counter := V'Length (1) *
6360 -- V'Length (N) - Counter;
6362 -- Counter_Id denotes the entity of the counter.
6364 function Build_Finalization_Call
return Node_Id
;
6365 -- Generate a deep finalization call for an array element
6367 procedure Build_Indexes
;
6368 -- Generate the initialization and finalization indexes used in the
6371 function Build_Initialization_Call
return Node_Id
;
6372 -- Generate a deep initialization call for an array element
6374 ----------------------
6375 -- Build_Assignment --
6376 ----------------------
6378 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6383 -- Start from the first dimension and generate:
6388 Make_Attribute_Reference
(Loc
,
6389 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6390 Attribute_Name
=> Name_Length
,
6391 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6393 -- Process the rest of the dimensions, generate:
6394 -- Expr * V'Length (N)
6397 while Dim
<= Num_Dims
loop
6399 Make_Op_Multiply
(Loc
,
6402 Make_Attribute_Reference
(Loc
,
6403 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6404 Attribute_Name
=> Name_Length
,
6405 Expressions
=> New_List
(
6406 Make_Integer_Literal
(Loc
, Dim
))));
6412 -- Counter := Expr - Counter;
6415 Make_Assignment_Statement
(Loc
,
6416 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6418 Make_Op_Subtract
(Loc
,
6420 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6421 end Build_Assignment
;
6423 -----------------------------
6424 -- Build_Finalization_Call --
6425 -----------------------------
6427 function Build_Finalization_Call
return Node_Id
is
6428 Comp_Ref
: constant Node_Id
:=
6429 Make_Indexed_Component
(Loc
,
6430 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6431 Expressions
=> New_References_To
(Final_List
, Loc
));
6434 Set_Etype
(Comp_Ref
, Comp_Typ
);
6437 -- [Deep_]Finalize (V);
6439 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6440 end Build_Finalization_Call
;
6446 procedure Build_Indexes
is
6448 -- Generate the following identifiers:
6449 -- Jnn - for initialization
6450 -- Fnn - for finalization
6452 for Dim
in 1 .. Num_Dims
loop
6453 Append_To
(Index_List
,
6454 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6456 Append_To
(Final_List
,
6457 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6461 -------------------------------
6462 -- Build_Initialization_Call --
6463 -------------------------------
6465 function Build_Initialization_Call
return Node_Id
is
6466 Comp_Ref
: constant Node_Id
:=
6467 Make_Indexed_Component
(Loc
,
6468 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6469 Expressions
=> New_References_To
(Index_List
, Loc
));
6472 Set_Etype
(Comp_Ref
, Comp_Typ
);
6475 -- [Deep_]Initialize (V (J1, ..., JN));
6477 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6478 end Build_Initialization_Call
;
6482 Counter_Id
: Entity_Id
;
6486 Final_Block
: Node_Id
;
6487 Final_Data
: Finalization_Exception_Data
;
6488 Final_Decls
: List_Id
:= No_List
;
6489 Final_Loop
: Node_Id
;
6490 Init_Block
: Node_Id
;
6491 Init_Call
: Node_Id
;
6492 Init_Loop
: Node_Id
;
6497 -- Start of processing for Build_Initialize_Statements
6500 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6501 Final_Decls
:= New_List
;
6504 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6506 -- Generate the block which houses the finalization call, the index
6507 -- guard and the handler which triggers Program_Error later on.
6509 -- if Counter > 0 then
6510 -- Counter := Counter - 1;
6513 -- [Deep_]Finalize (V (F1, ..., FN));
6516 -- if not Raised then
6518 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6523 Fin_Stmt
:= Build_Finalization_Call
;
6525 if Present
(Fin_Stmt
) then
6526 if Exceptions_OK
then
6528 Make_Block_Statement
(Loc
,
6529 Handled_Statement_Sequence
=>
6530 Make_Handled_Sequence_Of_Statements
(Loc
,
6531 Statements
=> New_List
(Fin_Stmt
),
6532 Exception_Handlers
=> New_List
(
6533 Build_Exception_Handler
(Final_Data
))));
6536 -- This is the core of the loop, the dimension iterators are added
6537 -- one by one in reverse.
6540 Make_If_Statement
(Loc
,
6543 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6544 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6546 Then_Statements
=> New_List
(
6547 Make_Assignment_Statement
(Loc
,
6548 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6550 Make_Op_Subtract
(Loc
,
6551 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6552 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6554 Else_Statements
=> New_List
(Fin_Stmt
));
6556 -- Generate all finalization loops starting from the innermost
6559 -- for Fnn in reverse V'Range (Dim) loop
6563 F
:= Last
(Final_List
);
6565 while Present
(F
) and then Dim
> 0 loop
6571 Make_Loop_Statement
(Loc
,
6573 Make_Iteration_Scheme
(Loc
,
6574 Loop_Parameter_Specification
=>
6575 Make_Loop_Parameter_Specification
(Loc
,
6576 Defining_Identifier
=> Loop_Id
,
6577 Discrete_Subtype_Definition
=>
6578 Make_Attribute_Reference
(Loc
,
6579 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6580 Attribute_Name
=> Name_Range
,
6581 Expressions
=> New_List
(
6582 Make_Integer_Literal
(Loc
, Dim
))),
6584 Reverse_Present
=> True)),
6586 Statements
=> New_List
(Final_Loop
),
6587 End_Label
=> Empty
);
6592 -- Generate the block which contains the finalization loops, the
6593 -- declarations of the abort flag, the exception occurrence, the
6594 -- raised flag and the conditional raise.
6597 -- Abort : constant Boolean := Triggered_By_Abort;
6599 -- Abort : constant Boolean := False; -- no abort
6601 -- E : Exception_Occurrence;
6602 -- Raised : Boolean := False;
6608 -- V'Length (N) - Counter;
6612 -- if Raised and then not Abort then
6613 -- Raise_From_Controlled_Operation (E);
6619 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6621 if Exceptions_OK
then
6622 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6623 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6627 Make_Block_Statement
(Loc
,
6628 Declarations
=> Final_Decls
,
6629 Handled_Statement_Sequence
=>
6630 Make_Handled_Sequence_Of_Statements
(Loc
,
6631 Statements
=> Stmts
));
6633 -- Otherwise previous errors or a missing full view may prevent the
6634 -- proper freezing of the component type. If this is the case, there
6635 -- is no [Deep_]Finalize primitive to call.
6638 Final_Block
:= Make_Null_Statement
(Loc
);
6641 -- Generate the block which contains the initialization call and
6642 -- the partial finalization code.
6645 -- [Deep_]Initialize (V (J1, ..., JN));
6647 -- Counter := Counter + 1;
6651 -- <finalization code>
6654 Init_Call
:= Build_Initialization_Call
;
6656 -- Only create finalization block if there is a nontrivial call
6657 -- to initialization or a Default_Initial_Condition check to be
6660 if (Present
(Init_Call
)
6661 and then Nkind
(Init_Call
) /= N_Null_Statement
)
6664 and then not GNATprove_Mode
6665 and then Present
(DIC_Procedure
(Comp_Typ
))
6666 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
6669 Init_Stmts
: constant List_Id
:= New_List
;
6672 if Present
(Init_Call
) then
6673 Append_To
(Init_Stmts
, Init_Call
);
6676 if Has_DIC
(Comp_Typ
)
6677 and then Present
(DIC_Procedure
(Comp_Typ
))
6681 Build_DIC_Call
(Loc
,
6682 Make_Indexed_Component
(Loc
,
6683 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6684 Expressions
=> New_References_To
(Index_List
, Loc
)),
6689 Make_Block_Statement
(Loc
,
6690 Handled_Statement_Sequence
=>
6691 Make_Handled_Sequence_Of_Statements
(Loc
,
6692 Statements
=> Init_Stmts
,
6693 Exception_Handlers
=> New_List
(
6694 Make_Exception_Handler
(Loc
,
6695 Exception_Choices
=> New_List
(
6696 Make_Others_Choice
(Loc
)),
6697 Statements
=> New_List
(Final_Block
)))));
6700 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6701 Make_Assignment_Statement
(Loc
,
6702 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6705 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6706 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6708 -- Generate all initialization loops starting from the innermost
6711 -- for Jnn in V'Range (Dim) loop
6715 J
:= Last
(Index_List
);
6717 while Present
(J
) and then Dim
> 0 loop
6723 Make_Loop_Statement
(Loc
,
6725 Make_Iteration_Scheme
(Loc
,
6726 Loop_Parameter_Specification
=>
6727 Make_Loop_Parameter_Specification
(Loc
,
6728 Defining_Identifier
=> Loop_Id
,
6729 Discrete_Subtype_Definition
=>
6730 Make_Attribute_Reference
(Loc
,
6731 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6732 Attribute_Name
=> Name_Range
,
6733 Expressions
=> New_List
(
6734 Make_Integer_Literal
(Loc
, Dim
))))),
6736 Statements
=> New_List
(Init_Loop
),
6737 End_Label
=> Empty
);
6742 -- Generate the block which contains the counter variable and the
6743 -- initialization loops.
6746 -- Counter : Integer := 0;
6752 Make_Block_Statement
(Loc
,
6753 Declarations
=> New_List
(
6754 Make_Object_Declaration
(Loc
,
6755 Defining_Identifier
=> Counter_Id
,
6756 Object_Definition
=>
6757 New_Occurrence_Of
(Standard_Integer
, Loc
),
6758 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6760 Handled_Statement_Sequence
=>
6761 Make_Handled_Sequence_Of_Statements
(Loc
,
6762 Statements
=> New_List
(Init_Loop
)));
6764 if Debug_Generated_Code
then
6765 Set_Debug_Info_Needed
(Counter_Id
);
6768 -- Otherwise previous errors or a missing full view may prevent the
6769 -- proper freezing of the component type. If this is the case, there
6770 -- is no [Deep_]Initialize primitive to call.
6773 Init_Block
:= Make_Null_Statement
(Loc
);
6776 return New_List
(Init_Block
);
6777 end Build_Initialize_Statements
;
6779 -----------------------
6780 -- New_References_To --
6781 -----------------------
6783 function New_References_To
6785 Loc
: Source_Ptr
) return List_Id
6787 Refs
: constant List_Id
:= New_List
;
6792 while Present
(Id
) loop
6793 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6798 end New_References_To
;
6800 -- Start of processing for Make_Deep_Array_Body
6804 when Address_Case
=>
6805 return Make_Finalize_Address_Stmts
(Typ
);
6810 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6812 when Initialize_Case
=>
6813 return Build_Initialize_Statements
(Typ
);
6815 end Make_Deep_Array_Body
;
6817 --------------------
6818 -- Make_Deep_Proc --
6819 --------------------
6821 function Make_Deep_Proc
6822 (Prim
: Final_Primitives
;
6824 Stmts
: List_Id
) return Entity_Id
6826 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6828 Proc_Id
: Entity_Id
;
6831 -- Create the object formal, generate:
6832 -- V : System.Address
6834 if Prim
= Address_Case
then
6835 Formals
:= New_List
(
6836 Make_Parameter_Specification
(Loc
,
6837 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6839 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6846 Formals
:= New_List
(
6847 Make_Parameter_Specification
(Loc
,
6848 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6850 Out_Present
=> True,
6851 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6853 -- F : Boolean := True
6855 if Prim
= Adjust_Case
6856 or else Prim
= Finalize_Case
6859 Make_Parameter_Specification
(Loc
,
6860 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6862 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6864 New_Occurrence_Of
(Standard_True
, Loc
)));
6869 Make_Defining_Identifier
(Loc
,
6870 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6873 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6876 -- exception -- Finalize and Adjust cases only
6877 -- raise Program_Error;
6878 -- end Deep_Initialize / Adjust / Finalize;
6882 -- procedure Finalize_Address (V : System.Address) is
6885 -- end Finalize_Address;
6888 Make_Subprogram_Body
(Loc
,
6890 Make_Procedure_Specification
(Loc
,
6891 Defining_Unit_Name
=> Proc_Id
,
6892 Parameter_Specifications
=> Formals
),
6894 Declarations
=> Empty_List
,
6896 Handled_Statement_Sequence
=>
6897 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6899 -- If there are no calls to component initialization, indicate that
6900 -- the procedure is trivial, so prevent calls to it.
6902 if Is_Empty_List
(Stmts
)
6903 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6905 Set_Is_Trivial_Subprogram
(Proc_Id
);
6911 ---------------------------
6912 -- Make_Deep_Record_Body --
6913 ---------------------------
6915 function Make_Deep_Record_Body
6916 (Prim
: Final_Primitives
;
6918 Is_Local
: Boolean := False) return List_Id
6920 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6921 -- Build the statements necessary to adjust a record type. The type may
6922 -- have discriminants and contain variant parts. Generate:
6926 -- [Deep_]Adjust (V.Comp_1);
6928 -- when Id : others =>
6929 -- if not Raised then
6931 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6936 -- [Deep_]Adjust (V.Comp_N);
6938 -- when Id : others =>
6939 -- if not Raised then
6941 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6946 -- Deep_Adjust (V._parent, False); -- If applicable
6948 -- when Id : others =>
6949 -- if not Raised then
6951 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6957 -- Adjust (V); -- If applicable
6960 -- if not Raised then
6962 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6967 -- if Raised and then not Abort then
6968 -- Raise_From_Controlled_Operation (E);
6972 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6973 -- Build the statements necessary to finalize a record type. The type
6974 -- may have discriminants and contain variant parts. Generate:
6977 -- Abort : constant Boolean := Triggered_By_Abort;
6979 -- Abort : constant Boolean := False; -- no abort
6980 -- E : Exception_Occurrence;
6981 -- Raised : Boolean := False;
6986 -- Finalize (V); -- If applicable
6989 -- if not Raised then
6991 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6996 -- case Variant_1 is
6998 -- case State_Counter_N => -- If Is_Local is enabled
7008 -- <<LN>> -- If Is_Local is enabled
7010 -- [Deep_]Finalize (V.Comp_N);
7013 -- if not Raised then
7015 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7021 -- [Deep_]Finalize (V.Comp_1);
7024 -- if not Raised then
7026 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7032 -- case State_Counter_1 => -- If Is_Local is enabled
7038 -- Deep_Finalize (V._parent, False); -- If applicable
7040 -- when Id : others =>
7041 -- if not Raised then
7043 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7047 -- if Raised and then not Abort then
7048 -- Raise_From_Controlled_Operation (E);
7052 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7053 -- Given a derived tagged type Typ, traverse all components, find field
7054 -- _parent and return its type.
7056 procedure Preprocess_Components
7058 Num_Comps
: out Nat
;
7059 Has_POC
: out Boolean);
7060 -- Examine all components in component list Comps, count all controlled
7061 -- components and determine whether at least one of them is per-object
7062 -- constrained. Component _parent is always skipped.
7064 -----------------------------
7065 -- Build_Adjust_Statements --
7066 -----------------------------
7068 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7069 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7070 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7072 Finalizer_Data
: Finalization_Exception_Data
;
7074 function Process_Component_List_For_Adjust
7075 (Comps
: Node_Id
) return List_Id
;
7076 -- Build all necessary adjust statements for a single component list
7078 ---------------------------------------
7079 -- Process_Component_List_For_Adjust --
7080 ---------------------------------------
7082 function Process_Component_List_For_Adjust
7083 (Comps
: Node_Id
) return List_Id
7085 Stmts
: constant List_Id
:= New_List
;
7087 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7088 -- Process the declaration of a single controlled component
7090 ----------------------------------
7091 -- Process_Component_For_Adjust --
7092 ----------------------------------
7094 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7095 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7096 Typ
: constant Entity_Id
:= Etype
(Id
);
7102 -- [Deep_]Adjust (V.Id);
7106 -- if not Raised then
7108 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7115 Make_Selected_Component
(Loc
,
7116 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7117 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7120 -- Guard against a missing [Deep_]Adjust when the component
7121 -- type was not properly frozen.
7123 if Present
(Adj_Call
) then
7124 if Exceptions_OK
then
7126 Make_Block_Statement
(Loc
,
7127 Handled_Statement_Sequence
=>
7128 Make_Handled_Sequence_Of_Statements
(Loc
,
7129 Statements
=> New_List
(Adj_Call
),
7130 Exception_Handlers
=> New_List
(
7131 Build_Exception_Handler
(Finalizer_Data
))));
7134 Append_To
(Stmts
, Adj_Call
);
7136 end Process_Component_For_Adjust
;
7141 Decl_Id
: Entity_Id
;
7142 Decl_Typ
: Entity_Id
;
7147 -- Start of processing for Process_Component_List_For_Adjust
7150 -- Perform an initial check, determine the number of controlled
7151 -- components in the current list and whether at least one of them
7152 -- is per-object constrained.
7154 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7156 -- The processing in this routine is done in the following order:
7157 -- 1) Regular components
7158 -- 2) Per-object constrained components
7161 if Num_Comps
> 0 then
7163 -- Process all regular components in order of declarations
7165 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7166 while Present
(Decl
) loop
7167 Decl_Id
:= Defining_Identifier
(Decl
);
7168 Decl_Typ
:= Etype
(Decl_Id
);
7170 -- Skip _parent as well as per-object constrained components
7172 if Chars
(Decl_Id
) /= Name_uParent
7173 and then Needs_Finalization
(Decl_Typ
)
7175 if Has_Access_Constraint
(Decl_Id
)
7176 and then No
(Expression
(Decl
))
7180 Process_Component_For_Adjust
(Decl
);
7184 Next_Non_Pragma
(Decl
);
7187 -- Process all per-object constrained components in order of
7191 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7192 while Present
(Decl
) loop
7193 Decl_Id
:= Defining_Identifier
(Decl
);
7194 Decl_Typ
:= Etype
(Decl_Id
);
7198 if Chars
(Decl_Id
) /= Name_uParent
7199 and then Needs_Finalization
(Decl_Typ
)
7200 and then Has_Access_Constraint
(Decl_Id
)
7201 and then No
(Expression
(Decl
))
7203 Process_Component_For_Adjust
(Decl
);
7206 Next_Non_Pragma
(Decl
);
7211 -- Process all variants, if any
7214 if Present
(Variant_Part
(Comps
)) then
7216 Var_Alts
: constant List_Id
:= New_List
;
7220 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7221 while Present
(Var
) loop
7224 -- when <discrete choices> =>
7225 -- <adjust statements>
7227 Append_To
(Var_Alts
,
7228 Make_Case_Statement_Alternative
(Loc
,
7230 New_Copy_List
(Discrete_Choices
(Var
)),
7232 Process_Component_List_For_Adjust
(
7233 Component_List
(Var
))));
7235 Next_Non_Pragma
(Var
);
7239 -- case V.<discriminant> is
7240 -- when <discrete choices 1> =>
7241 -- <adjust statements 1>
7243 -- when <discrete choices N> =>
7244 -- <adjust statements N>
7248 Make_Case_Statement
(Loc
,
7250 Make_Selected_Component
(Loc
,
7251 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7253 Make_Identifier
(Loc
,
7254 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7255 Alternatives
=> Var_Alts
);
7259 -- Add the variant case statement to the list of statements
7261 if Present
(Var_Case
) then
7262 Append_To
(Stmts
, Var_Case
);
7265 -- If the component list did not have any controlled components
7266 -- nor variants, return null.
7268 if Is_Empty_List
(Stmts
) then
7269 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7273 end Process_Component_List_For_Adjust
;
7277 Bod_Stmts
: List_Id
:= No_List
;
7278 Finalizer_Decls
: List_Id
:= No_List
;
7281 -- Start of processing for Build_Adjust_Statements
7284 Finalizer_Decls
:= New_List
;
7285 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7287 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7288 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7293 -- Create an adjust sequence for all record components
7295 if Present
(Component_List
(Rec_Def
)) then
7297 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7300 -- A derived record type must adjust all inherited components. This
7301 -- action poses the following problem:
7303 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7308 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7310 -- Deep_Adjust (Obj._parent);
7315 -- Adjusting the derived type will invoke Adjust of the parent and
7316 -- then that of the derived type. This is undesirable because both
7317 -- routines may modify shared components. Only the Adjust of the
7318 -- derived type should be invoked.
7320 -- To prevent this double adjustment of shared components,
7321 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7323 -- procedure Deep_Adjust
7324 -- (Obj : in out Some_Type;
7325 -- Flag : Boolean := True)
7333 -- When Deep_Adjust is invoked for field _parent, a value of False is
7334 -- provided for the flag:
7336 -- Deep_Adjust (Obj._parent, False);
7338 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7340 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7345 if Needs_Finalization
(Par_Typ
) then
7349 Make_Selected_Component
(Loc
,
7350 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7352 Make_Identifier
(Loc
, Name_uParent
)),
7358 -- Deep_Adjust (V._parent, False);
7361 -- when Id : others =>
7362 -- if not Raised then
7364 -- Save_Occurrence (E,
7365 -- Get_Current_Excep.all.all);
7369 if Present
(Call
) then
7372 if Exceptions_OK
then
7374 Make_Block_Statement
(Loc
,
7375 Handled_Statement_Sequence
=>
7376 Make_Handled_Sequence_Of_Statements
(Loc
,
7377 Statements
=> New_List
(Adj_Stmt
),
7378 Exception_Handlers
=> New_List
(
7379 Build_Exception_Handler
(Finalizer_Data
))));
7382 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7388 -- Adjust the object. This action must be performed last after all
7389 -- components have been adjusted.
7391 if Is_Controlled
(Typ
) then
7397 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7406 -- if not Raised then
7408 -- Save_Occurrence (E,
7409 -- Get_Current_Excep.all.all);
7414 if Present
(Proc
) then
7416 Make_Procedure_Call_Statement
(Loc
,
7417 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7418 Parameter_Associations
=> New_List
(
7419 Make_Identifier
(Loc
, Name_V
)));
7421 if Exceptions_OK
then
7423 Make_Block_Statement
(Loc
,
7424 Handled_Statement_Sequence
=>
7425 Make_Handled_Sequence_Of_Statements
(Loc
,
7426 Statements
=> New_List
(Adj_Stmt
),
7427 Exception_Handlers
=> New_List
(
7428 Build_Exception_Handler
7429 (Finalizer_Data
))));
7432 Append_To
(Bod_Stmts
,
7433 Make_If_Statement
(Loc
,
7434 Condition
=> Make_Identifier
(Loc
, Name_F
),
7435 Then_Statements
=> New_List
(Adj_Stmt
)));
7440 -- At this point either all adjustment statements have been generated
7441 -- or the type is not controlled.
7443 if Is_Empty_List
(Bod_Stmts
) then
7444 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7450 -- Abort : constant Boolean := Triggered_By_Abort;
7452 -- Abort : constant Boolean := False; -- no abort
7454 -- E : Exception_Occurrence;
7455 -- Raised : Boolean := False;
7458 -- <adjust statements>
7460 -- if Raised and then not Abort then
7461 -- Raise_From_Controlled_Operation (E);
7466 if Exceptions_OK
then
7467 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7472 Make_Block_Statement
(Loc
,
7475 Handled_Statement_Sequence
=>
7476 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7478 end Build_Adjust_Statements
;
7480 -------------------------------
7481 -- Build_Finalize_Statements --
7482 -------------------------------
7484 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7485 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7486 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7489 Finalizer_Data
: Finalization_Exception_Data
;
7490 Last_POC_Call
: Node_Id
:= Empty
;
7492 function Process_Component_List_For_Finalize
7494 In_Variant_Part
: Boolean := False) return List_Id
;
7495 -- Build all necessary finalization statements for a single component
7496 -- list. The statements may include a jump circuitry if flag Is_Local
7497 -- is enabled. In_Variant_Part indicates whether this is a recursive
7500 -----------------------------------------
7501 -- Process_Component_List_For_Finalize --
7502 -----------------------------------------
7504 function Process_Component_List_For_Finalize
7506 In_Variant_Part
: Boolean := False) return List_Id
7508 procedure Process_Component_For_Finalize
7513 Num_Comps
: in out Nat
);
7514 -- Process the declaration of a single controlled component. If
7515 -- flag Is_Local is enabled, create the corresponding label and
7516 -- jump circuitry. Alts is the list of case alternatives, Decls
7517 -- is the top level declaration list where labels are declared
7518 -- and Stmts is the list of finalization actions. Num_Comps
7519 -- denotes the current number of components needing finalization.
7521 ------------------------------------
7522 -- Process_Component_For_Finalize --
7523 ------------------------------------
7525 procedure Process_Component_For_Finalize
7530 Num_Comps
: in out Nat
)
7532 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7533 Typ
: constant Entity_Id
:= Etype
(Id
);
7540 Label_Id
: Entity_Id
;
7547 Make_Identifier
(Loc
,
7548 Chars
=> New_External_Name
('L', Num_Comps
));
7549 Set_Entity
(Label_Id
,
7550 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7551 Label
:= Make_Label
(Loc
, Label_Id
);
7554 Make_Implicit_Label_Declaration
(Loc
,
7555 Defining_Identifier
=> Entity
(Label_Id
),
7556 Label_Construct
=> Label
));
7563 Make_Case_Statement_Alternative
(Loc
,
7564 Discrete_Choices
=> New_List
(
7565 Make_Integer_Literal
(Loc
, Num_Comps
)),
7567 Statements
=> New_List
(
7568 Make_Goto_Statement
(Loc
,
7570 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7575 Append_To
(Stmts
, Label
);
7577 -- Decrease the number of components to be processed.
7578 -- This action yields a new Label_Id in future calls.
7580 Num_Comps
:= Num_Comps
- 1;
7585 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7587 -- begin -- Exception handlers allowed
7588 -- [Deep_]Finalize (V.Id);
7591 -- if not Raised then
7593 -- Save_Occurrence (E,
7594 -- Get_Current_Excep.all.all);
7601 Make_Selected_Component
(Loc
,
7602 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7603 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7606 -- Guard against a missing [Deep_]Finalize when the component
7607 -- type was not properly frozen.
7609 if Present
(Fin_Call
) then
7610 if Exceptions_OK
then
7612 Make_Block_Statement
(Loc
,
7613 Handled_Statement_Sequence
=>
7614 Make_Handled_Sequence_Of_Statements
(Loc
,
7615 Statements
=> New_List
(Fin_Call
),
7616 Exception_Handlers
=> New_List
(
7617 Build_Exception_Handler
(Finalizer_Data
))));
7620 Append_To
(Stmts
, Fin_Call
);
7622 end Process_Component_For_Finalize
;
7627 Counter_Id
: Entity_Id
:= Empty
;
7629 Decl_Id
: Entity_Id
;
7630 Decl_Typ
: Entity_Id
;
7633 Jump_Block
: Node_Id
;
7635 Label_Id
: Entity_Id
;
7640 -- Start of processing for Process_Component_List_For_Finalize
7643 -- Perform an initial check, look for controlled and per-object
7644 -- constrained components.
7646 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7648 -- Create a state counter to service the current component list.
7649 -- This step is performed before the variants are inspected in
7650 -- order to generate the same state counter names as those from
7651 -- Build_Initialize_Statements.
7653 if Num_Comps
> 0 and then Is_Local
then
7654 Counter
:= Counter
+ 1;
7657 Make_Defining_Identifier
(Loc
,
7658 Chars
=> New_External_Name
('C', Counter
));
7661 -- Process the component in the following order:
7663 -- 2) Per-object constrained components
7664 -- 3) Regular components
7666 -- Start with the variant parts
7669 if Present
(Variant_Part
(Comps
)) then
7671 Var_Alts
: constant List_Id
:= New_List
;
7675 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7676 while Present
(Var
) loop
7679 -- when <discrete choices> =>
7680 -- <finalize statements>
7682 Append_To
(Var_Alts
,
7683 Make_Case_Statement_Alternative
(Loc
,
7685 New_Copy_List
(Discrete_Choices
(Var
)),
7687 Process_Component_List_For_Finalize
(
7688 Component_List
(Var
),
7689 In_Variant_Part
=> True)));
7691 Next_Non_Pragma
(Var
);
7695 -- case V.<discriminant> is
7696 -- when <discrete choices 1> =>
7697 -- <finalize statements 1>
7699 -- when <discrete choices N> =>
7700 -- <finalize statements N>
7704 Make_Case_Statement
(Loc
,
7706 Make_Selected_Component
(Loc
,
7707 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7709 Make_Identifier
(Loc
,
7710 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7711 Alternatives
=> Var_Alts
);
7715 -- The current component list does not have a single controlled
7716 -- component, however it may contain variants. Return the case
7717 -- statement for the variants or nothing.
7719 if Num_Comps
= 0 then
7720 if Present
(Var_Case
) then
7721 return New_List
(Var_Case
);
7723 return New_List
(Make_Null_Statement
(Loc
));
7727 -- Prepare all lists
7733 -- Process all per-object constrained components in reverse order
7736 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7737 while Present
(Decl
) loop
7738 Decl_Id
:= Defining_Identifier
(Decl
);
7739 Decl_Typ
:= Etype
(Decl_Id
);
7743 if Chars
(Decl_Id
) /= Name_uParent
7744 and then Needs_Finalization
(Decl_Typ
)
7745 and then Has_Access_Constraint
(Decl_Id
)
7746 and then No
(Expression
(Decl
))
7748 Process_Component_For_Finalize
7749 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7752 Prev_Non_Pragma
(Decl
);
7756 if not In_Variant_Part
then
7757 Last_POC_Call
:= Last
(Stmts
);
7758 -- In the case of a type extension, the deep-finalize call
7759 -- for the _Parent component will be inserted here.
7762 -- Process the rest of the components in reverse order
7764 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7765 while Present
(Decl
) loop
7766 Decl_Id
:= Defining_Identifier
(Decl
);
7767 Decl_Typ
:= Etype
(Decl_Id
);
7771 if Chars
(Decl_Id
) /= Name_uParent
7772 and then Needs_Finalization
(Decl_Typ
)
7774 -- Skip per-object constrained components since they were
7775 -- handled in the above step.
7777 if Has_Access_Constraint
(Decl_Id
)
7778 and then No
(Expression
(Decl
))
7782 Process_Component_For_Finalize
7783 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7787 Prev_Non_Pragma
(Decl
);
7792 -- LN : label; -- If Is_Local is enabled
7797 -- case CounterX is .
7807 -- <<LN>> -- If Is_Local is enabled
7809 -- [Deep_]Finalize (V.CompY);
7811 -- when Id : others =>
7812 -- if not Raised then
7814 -- Save_Occurrence (E,
7815 -- Get_Current_Excep.all.all);
7819 -- <<L0>> -- If Is_Local is enabled
7824 -- Add the declaration of default jump location L0, its
7825 -- corresponding alternative and its place in the statements.
7827 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7828 Set_Entity
(Label_Id
,
7829 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7830 Label
:= Make_Label
(Loc
, Label_Id
);
7832 Append_To
(Decls
, -- declaration
7833 Make_Implicit_Label_Declaration
(Loc
,
7834 Defining_Identifier
=> Entity
(Label_Id
),
7835 Label_Construct
=> Label
));
7837 Append_To
(Alts
, -- alternative
7838 Make_Case_Statement_Alternative
(Loc
,
7839 Discrete_Choices
=> New_List
(
7840 Make_Others_Choice
(Loc
)),
7842 Statements
=> New_List
(
7843 Make_Goto_Statement
(Loc
,
7844 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7846 Append_To
(Stmts
, Label
); -- statement
7848 -- Create the jump block
7851 Make_Case_Statement
(Loc
,
7852 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7853 Alternatives
=> Alts
));
7857 Make_Block_Statement
(Loc
,
7858 Declarations
=> Decls
,
7859 Handled_Statement_Sequence
=>
7860 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7862 if Present
(Var_Case
) then
7863 return New_List
(Var_Case
, Jump_Block
);
7865 return New_List
(Jump_Block
);
7867 end Process_Component_List_For_Finalize
;
7871 Bod_Stmts
: List_Id
:= No_List
;
7872 Finalizer_Decls
: List_Id
:= No_List
;
7875 -- Start of processing for Build_Finalize_Statements
7878 Finalizer_Decls
:= New_List
;
7879 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7881 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7882 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7887 -- Create a finalization sequence for all record components
7889 if Present
(Component_List
(Rec_Def
)) then
7891 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7894 -- A derived record type must finalize all inherited components. This
7895 -- action poses the following problem:
7897 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7902 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7904 -- Deep_Finalize (Obj._parent);
7909 -- Finalizing the derived type will invoke Finalize of the parent and
7910 -- then that of the derived type. This is undesirable because both
7911 -- routines may modify shared components. Only the Finalize of the
7912 -- derived type should be invoked.
7914 -- To prevent this double adjustment of shared components,
7915 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7917 -- procedure Deep_Finalize
7918 -- (Obj : in out Some_Type;
7919 -- Flag : Boolean := True)
7927 -- When Deep_Finalize is invoked for field _parent, a value of False
7928 -- is provided for the flag:
7930 -- Deep_Finalize (Obj._parent, False);
7932 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7934 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7939 if Needs_Finalization
(Par_Typ
) then
7943 Make_Selected_Component
(Loc
,
7944 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7946 Make_Identifier
(Loc
, Name_uParent
)),
7952 -- Deep_Finalize (V._parent, False);
7955 -- when Id : others =>
7956 -- if not Raised then
7958 -- Save_Occurrence (E,
7959 -- Get_Current_Excep.all.all);
7963 if Present
(Call
) then
7966 if Exceptions_OK
then
7968 Make_Block_Statement
(Loc
,
7969 Handled_Statement_Sequence
=>
7970 Make_Handled_Sequence_Of_Statements
(Loc
,
7971 Statements
=> New_List
(Fin_Stmt
),
7972 Exception_Handlers
=> New_List
(
7973 Build_Exception_Handler
7974 (Finalizer_Data
))));
7977 -- The intended component finalization order is
7978 -- 1) POC components of extension
7979 -- 2) _Parent component
7980 -- 3) non-POC components of extension.
7982 -- With this "finalize the parent part in the middle"
7983 -- ordering, we can avoid the need for making two
7984 -- calls to the parent's subprogram in the way that
7985 -- is necessary for Init_Procs. This does have the
7986 -- peculiar (but legal) consequence that the parent's
7987 -- non-POC components are finalized before the
7988 -- non-POC extension components. This violates the
7989 -- usual "finalize in reverse declaration order"
7990 -- principle, but that's ok (see Ada RM 7.6.1(9)).
7992 -- Last_POC_Call should be non-empty if the extension
7993 -- has at least one POC. Interactions with variant
7994 -- parts are incorrectly ignored.
7996 if Present
(Last_POC_Call
) then
7997 Insert_After
(Last_POC_Call
, Fin_Stmt
);
7999 -- At this point, we could look for the common case
8000 -- where there are no POC components anywhere in
8001 -- sight (inherited or not) and, in that common case,
8002 -- call Append_To instead of Prepend_To. That would
8003 -- result in finalizing the parent part after, rather
8004 -- than before, the extension components. That might
8005 -- be more intuitive (as discussed in preceding
8006 -- comment), but it is not required.
8007 Prepend_To
(Bod_Stmts
, Fin_Stmt
);
8014 -- Finalize the object. This action must be performed first before
8015 -- all components have been finalized.
8017 if Is_Controlled
(Typ
) and then not Is_Local
then
8023 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8032 -- if not Raised then
8034 -- Save_Occurrence (E,
8035 -- Get_Current_Excep.all.all);
8040 if Present
(Proc
) then
8042 Make_Procedure_Call_Statement
(Loc
,
8043 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8044 Parameter_Associations
=> New_List
(
8045 Make_Identifier
(Loc
, Name_V
)));
8047 if Exceptions_OK
then
8049 Make_Block_Statement
(Loc
,
8050 Handled_Statement_Sequence
=>
8051 Make_Handled_Sequence_Of_Statements
(Loc
,
8052 Statements
=> New_List
(Fin_Stmt
),
8053 Exception_Handlers
=> New_List
(
8054 Build_Exception_Handler
8055 (Finalizer_Data
))));
8058 Prepend_To
(Bod_Stmts
,
8059 Make_If_Statement
(Loc
,
8060 Condition
=> Make_Identifier
(Loc
, Name_F
),
8061 Then_Statements
=> New_List
(Fin_Stmt
)));
8066 -- At this point either all finalization statements have been
8067 -- generated or the type is not controlled.
8069 if No
(Bod_Stmts
) then
8070 return New_List
(Make_Null_Statement
(Loc
));
8074 -- Abort : constant Boolean := Triggered_By_Abort;
8076 -- Abort : constant Boolean := False; -- no abort
8078 -- E : Exception_Occurrence;
8079 -- Raised : Boolean := False;
8082 -- <finalize statements>
8084 -- if Raised and then not Abort then
8085 -- Raise_From_Controlled_Operation (E);
8090 if Exceptions_OK
then
8091 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8096 Make_Block_Statement
(Loc
,
8099 Handled_Statement_Sequence
=>
8100 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8102 end Build_Finalize_Statements
;
8104 -----------------------
8105 -- Parent_Field_Type --
8106 -----------------------
8108 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8112 Field
:= First_Entity
(Typ
);
8113 while Present
(Field
) loop
8114 if Chars
(Field
) = Name_uParent
then
8115 return Etype
(Field
);
8118 Next_Entity
(Field
);
8121 -- A derived tagged type should always have a parent field
8123 raise Program_Error
;
8124 end Parent_Field_Type
;
8126 ---------------------------
8127 -- Preprocess_Components --
8128 ---------------------------
8130 procedure Preprocess_Components
8132 Num_Comps
: out Nat
;
8133 Has_POC
: out Boolean)
8143 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8144 while Present
(Decl
) loop
8145 Id
:= Defining_Identifier
(Decl
);
8148 -- Skip field _parent
8150 if Chars
(Id
) /= Name_uParent
8151 and then Needs_Finalization
(Typ
)
8153 Num_Comps
:= Num_Comps
+ 1;
8155 if Has_Access_Constraint
(Id
)
8156 and then No
(Expression
(Decl
))
8162 Next_Non_Pragma
(Decl
);
8164 end Preprocess_Components
;
8166 -- Start of processing for Make_Deep_Record_Body
8170 when Address_Case
=>
8171 return Make_Finalize_Address_Stmts
(Typ
);
8174 return Build_Adjust_Statements
(Typ
);
8176 when Finalize_Case
=>
8177 return Build_Finalize_Statements
(Typ
);
8179 when Initialize_Case
=>
8181 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8184 if Is_Controlled
(Typ
) then
8186 Make_Procedure_Call_Statement
(Loc
,
8189 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8190 Parameter_Associations
=> New_List
(
8191 Make_Identifier
(Loc
, Name_V
))));
8197 end Make_Deep_Record_Body
;
8199 ----------------------
8200 -- Make_Final_Call --
8201 ----------------------
8203 function Make_Final_Call
8206 Skip_Self
: Boolean := False) return Node_Id
8208 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8210 Prot_Typ
: Entity_Id
:= Empty
;
8211 Fin_Id
: Entity_Id
:= Empty
;
8218 -- Recover the proper type which contains [Deep_]Finalize
8220 if Is_Class_Wide_Type
(Typ
) then
8221 Utyp
:= Root_Type
(Typ
);
8224 elsif Is_Concurrent_Type
(Typ
) then
8225 Utyp
:= Corresponding_Record_Type
(Typ
);
8227 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8229 elsif Is_Private_Type
(Typ
)
8230 and then Present
(Underlying_Type
(Typ
))
8231 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8233 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8235 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8242 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8243 Set_Assignment_OK
(Ref
);
8245 -- Deal with untagged derivation of private views. If the parent type
8246 -- is a protected type, Deep_Finalize is found on the corresponding
8247 -- record of the ancestor.
8249 if Is_Untagged_Derivation
(Typ
) then
8250 if Is_Protected_Type
(Typ
) then
8251 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8253 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8255 if Is_Protected_Type
(Utyp
) then
8256 Utyp
:= Corresponding_Record_Type
(Utyp
);
8260 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8261 Set_Assignment_OK
(Ref
);
8264 -- Deal with derived private types which do not inherit primitives from
8265 -- their parents. In this case, [Deep_]Finalize can be found in the full
8266 -- view of the parent type.
8269 and then Is_Tagged_Type
(Utyp
)
8270 and then Is_Derived_Type
(Utyp
)
8271 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8272 and then Is_Private_Type
(Etype
(Utyp
))
8273 and then Present
(Full_View
(Etype
(Utyp
)))
8275 Utyp
:= Full_View
(Etype
(Utyp
));
8276 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8277 Set_Assignment_OK
(Ref
);
8280 -- When dealing with the completion of a private type, use the base type
8283 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8284 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8286 Utyp
:= Base_Type
(Utyp
);
8287 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8288 Set_Assignment_OK
(Ref
);
8291 -- Detect if Typ is a protected type or an expanded protected type and
8292 -- store the relevant type within Prot_Typ for later processing.
8294 if Is_Protected_Type
(Typ
) then
8297 elsif Ekind
(Typ
) = E_Record_Type
8298 and then Present
(Corresponding_Concurrent_Type
(Typ
))
8299 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Typ
))
8301 Prot_Typ
:= Corresponding_Concurrent_Type
(Typ
);
8304 -- The underlying type may not be present due to a missing full view. In
8305 -- this case freezing did not take place and there is no [Deep_]Finalize
8306 -- primitive to call.
8311 elsif Skip_Self
then
8312 if Has_Controlled_Component
(Utyp
) then
8313 if Is_Tagged_Type
(Utyp
) then
8314 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8316 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8320 -- Class-wide types, interfaces and types with controlled components
8322 elsif Is_Class_Wide_Type
(Typ
)
8323 or else Is_Interface
(Typ
)
8324 or else Has_Controlled_Component
(Utyp
)
8326 if Is_Tagged_Type
(Utyp
) then
8327 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8329 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8332 -- Derivations from [Limited_]Controlled
8334 elsif Is_Controlled
(Utyp
) then
8335 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8339 elsif Is_Tagged_Type
(Utyp
) then
8340 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8342 -- Protected types: these also require finalization even though they
8343 -- are not marked controlled explicitly.
8345 elsif Present
(Prot_Typ
) then
8346 -- Protected objects do not need to be finalized on restricted
8349 if Restricted_Profile
then
8352 -- ??? Only handle the simple case for now. Will not support a record
8353 -- or array containing protected objects.
8355 elsif Is_Simple_Protected_Type
(Prot_Typ
) then
8356 Fin_Id
:= RTE
(RE_Finalize_Protection
);
8358 raise Program_Error
;
8361 raise Program_Error
;
8364 if Present
(Fin_Id
) then
8366 -- When finalizing a class-wide object, do not convert to the root
8367 -- type in order to produce a dispatching call.
8369 if Is_Class_Wide_Type
(Typ
) then
8372 -- Ensure that a finalization routine is at least decorated in order
8373 -- to inspect the object parameter.
8375 elsif Analyzed
(Fin_Id
)
8376 or else Ekind
(Fin_Id
) = E_Procedure
8378 -- In certain cases, such as the creation of Stream_Read, the
8379 -- visible entity of the type is its full view. Since Stream_Read
8380 -- will have to create an object of type Typ, the local object
8381 -- will be finalzed by the scope finalizer generated later on. The
8382 -- object parameter of Deep_Finalize will always use the private
8383 -- view of the type. To avoid such a clash between a private and a
8384 -- full view, perform an unchecked conversion of the object
8385 -- reference to the private view.
8388 Formal_Typ
: constant Entity_Id
:=
8389 Etype
(First_Formal
(Fin_Id
));
8391 if Is_Private_Type
(Formal_Typ
)
8392 and then Present
(Full_View
(Formal_Typ
))
8393 and then Full_View
(Formal_Typ
) = Utyp
8395 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8399 -- If the object is unanalyzed, set its expected type for use in
8400 -- Convert_View in case an additional conversion is needed.
8403 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
8405 Set_Etype
(Ref
, Typ
);
8408 Ref
:= Convert_View
(Fin_Id
, Ref
);
8415 Skip_Self
=> Skip_Self
);
8417 pragma Assert
(Serious_Errors_Detected
> 0
8418 or else not Has_Controlled_Component
(Utyp
));
8421 end Make_Final_Call
;
8423 --------------------------------
8424 -- Make_Finalize_Address_Body --
8425 --------------------------------
8427 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8428 Is_Task
: constant Boolean :=
8429 Ekind
(Typ
) = E_Record_Type
8430 and then Is_Concurrent_Record_Type
(Typ
)
8431 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8433 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8434 Proc_Id
: Entity_Id
;
8438 -- The corresponding records of task types are not controlled by design.
8439 -- For the sake of completeness, create an empty Finalize_Address to be
8440 -- used in task class-wide allocations.
8445 -- Nothing to do if the type is not controlled or it already has a
8446 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8447 -- come from source. These are usually generated for completeness and
8448 -- do not need the Finalize_Address primitive.
8450 elsif not Needs_Finalization
(Typ
)
8451 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8453 (Is_Class_Wide_Type
(Typ
)
8454 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8455 and then not Comes_From_Source
(Root_Type
(Typ
)))
8460 -- Do not generate Finalize_Address routine for CodePeer
8462 if CodePeer_Mode
then
8467 Make_Defining_Identifier
(Loc
,
8468 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8472 -- procedure <Typ>FD (V : System.Address) is
8474 -- null; -- for tasks
8476 -- declare -- for all other types
8477 -- type Pnn is access all Typ;
8478 -- for Pnn'Storage_Size use 0;
8480 -- [Deep_]Finalize (Pnn (V).all);
8485 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8487 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8491 Make_Subprogram_Body
(Loc
,
8493 Make_Procedure_Specification
(Loc
,
8494 Defining_Unit_Name
=> Proc_Id
,
8496 Parameter_Specifications
=> New_List
(
8497 Make_Parameter_Specification
(Loc
,
8498 Defining_Identifier
=>
8499 Make_Defining_Identifier
(Loc
, Name_V
),
8501 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8503 Declarations
=> No_List
,
8505 Handled_Statement_Sequence
=>
8506 Make_Handled_Sequence_Of_Statements
(Loc
,
8507 Statements
=> Stmts
)));
8509 Set_TSS
(Typ
, Proc_Id
);
8510 end Make_Finalize_Address_Body
;
8512 ---------------------------------
8513 -- Make_Finalize_Address_Stmts --
8514 ---------------------------------
8516 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8517 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8520 Desig_Typ
: Entity_Id
;
8521 Fin_Block
: Node_Id
;
8524 Ptr_Typ
: Entity_Id
;
8527 if Is_Array_Type
(Typ
) then
8528 if Is_Constrained
(First_Subtype
(Typ
)) then
8529 Desig_Typ
:= First_Subtype
(Typ
);
8531 Desig_Typ
:= Base_Type
(Typ
);
8534 -- Class-wide types of constrained root types
8536 elsif Is_Class_Wide_Type
(Typ
)
8537 and then Has_Discriminants
(Root_Type
(Typ
))
8539 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8542 Parent_Typ
: Entity_Id
;
8543 Parent_Utyp
: Entity_Id
;
8546 -- Climb the parent type chain looking for a non-constrained type
8548 Parent_Typ
:= Root_Type
(Typ
);
8549 while Parent_Typ
/= Etype
(Parent_Typ
)
8550 and then Has_Discriminants
(Parent_Typ
)
8552 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8554 Parent_Typ
:= Etype
(Parent_Typ
);
8557 -- Handle views created for tagged types with unknown
8560 if Is_Underlying_Record_View
(Parent_Typ
) then
8561 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8564 Parent_Utyp
:= Underlying_Type
(Parent_Typ
);
8566 -- Handle views created for a synchronized private extension with
8567 -- known, non-defaulted discriminants. In that case, parent_typ
8568 -- will be the private extension, as it is the first "non
8569 -- -constrained" type in the parent chain. Unfortunately, the
8570 -- underlying type, being a protected or task type, is not the
8571 -- "real" type needing finalization. Rather, the "corresponding
8572 -- record type" should be the designated type here. In fact, TSS
8573 -- finalizer generation is specifically skipped for the nominal
8574 -- class-wide type of (the full view of) a concurrent type (see
8575 -- exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate
8576 -- the underlying record (Tprot_typeVC), we will end up trying to
8577 -- dispatch to prot_typeVDF from an incorrectly designated
8578 -- Tprot_typeC, which is, of course, not actually a member of
8579 -- prot_typeV'Class, and thus incompatible.
8581 if Ekind
(Parent_Utyp
) in Concurrent_Kind
8582 and then Present
(Corresponding_Record_Type
(Parent_Utyp
))
8584 Parent_Utyp
:= Corresponding_Record_Type
(Parent_Utyp
);
8587 Desig_Typ
:= Class_Wide_Type
(Parent_Utyp
);
8597 -- type Ptr_Typ is access all Typ;
8598 -- for Ptr_Typ'Storage_Size use 0;
8600 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8603 Make_Full_Type_Declaration
(Loc
,
8604 Defining_Identifier
=> Ptr_Typ
,
8606 Make_Access_To_Object_Definition
(Loc
,
8607 All_Present
=> True,
8608 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8610 Make_Attribute_Definition_Clause
(Loc
,
8611 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8612 Chars
=> Name_Storage_Size
,
8613 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8615 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8617 -- Unconstrained arrays require special processing in order to retrieve
8618 -- the elements. To achieve this, we have to skip the dope vector which
8619 -- lays in front of the elements and then use a thin pointer to perform
8620 -- the address-to-access conversion.
8622 if Is_Array_Type
(Typ
)
8623 and then not Is_Constrained
(First_Subtype
(Typ
))
8626 Dope_Id
: Entity_Id
;
8629 -- Ensure that Ptr_Typ is a thin pointer; generate:
8630 -- for Ptr_Typ'Size use System.Address'Size;
8633 Make_Attribute_Definition_Clause
(Loc
,
8634 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8637 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8640 -- Dnn : constant Storage_Offset :=
8641 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8643 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8646 Make_Object_Declaration
(Loc
,
8647 Defining_Identifier
=> Dope_Id
,
8648 Constant_Present
=> True,
8649 Object_Definition
=>
8650 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8652 Make_Op_Divide
(Loc
,
8654 Make_Attribute_Reference
(Loc
,
8655 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8656 Attribute_Name
=> Name_Descriptor_Size
),
8658 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8660 -- Shift the address from the start of the dope vector to the
8661 -- start of the elements:
8665 -- Note that this is done through a wrapper routine since RTSfind
8666 -- cannot retrieve operations with string names of the form "+".
8669 Make_Function_Call
(Loc
,
8671 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8672 Parameter_Associations
=> New_List
(
8674 New_Occurrence_Of
(Dope_Id
, Loc
)));
8681 Make_Explicit_Dereference
(Loc
,
8682 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8685 if Present
(Fin_Call
) then
8687 Make_Block_Statement
(Loc
,
8688 Declarations
=> Decls
,
8689 Handled_Statement_Sequence
=>
8690 Make_Handled_Sequence_Of_Statements
(Loc
,
8691 Statements
=> New_List
(Fin_Call
)));
8693 -- Otherwise previous errors or a missing full view may prevent the
8694 -- proper freezing of the designated type. If this is the case, there
8695 -- is no [Deep_]Finalize primitive to call.
8698 Fin_Block
:= Make_Null_Statement
(Loc
);
8701 return New_List
(Fin_Block
);
8702 end Make_Finalize_Address_Stmts
;
8704 -------------------------------------
8705 -- Make_Handler_For_Ctrl_Operation --
8706 -------------------------------------
8710 -- when E : others =>
8711 -- Raise_From_Controlled_Operation (E);
8716 -- raise Program_Error [finalize raised exception];
8718 -- depending on whether Raise_From_Controlled_Operation is available
8720 function Make_Handler_For_Ctrl_Operation
8721 (Loc
: Source_Ptr
) return Node_Id
8724 -- Choice parameter (for the first case above)
8726 Raise_Node
: Node_Id
;
8727 -- Procedure call or raise statement
8730 -- Standard run-time: add choice parameter E and pass it to
8731 -- Raise_From_Controlled_Operation so that the original exception
8732 -- name and message can be recorded in the exception message for
8735 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8736 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8738 Make_Procedure_Call_Statement
(Loc
,
8741 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8742 Parameter_Associations
=> New_List
(
8743 New_Occurrence_Of
(E_Occ
, Loc
)));
8745 -- Restricted run-time: exception messages are not supported
8750 Make_Raise_Program_Error
(Loc
,
8751 Reason
=> PE_Finalize_Raised_Exception
);
8755 Make_Implicit_Exception_Handler
(Loc
,
8756 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8757 Choice_Parameter
=> E_Occ
,
8758 Statements
=> New_List
(Raise_Node
));
8759 end Make_Handler_For_Ctrl_Operation
;
8761 --------------------
8762 -- Make_Init_Call --
8763 --------------------
8765 function Make_Init_Call
8767 Typ
: Entity_Id
) return Node_Id
8769 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8778 -- Deal with the type and object reference. Depending on the context, an
8779 -- object reference may need several conversions.
8781 if Is_Concurrent_Type
(Typ
) then
8783 Utyp
:= Corresponding_Record_Type
(Typ
);
8784 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8786 elsif Is_Private_Type
(Typ
)
8787 and then Present
(Full_View
(Typ
))
8788 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8791 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8792 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8799 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8800 Set_Assignment_OK
(Ref
);
8802 -- Deal with untagged derivation of private views
8804 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8805 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8806 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8808 -- The following is to prevent problems with UC see 1.156 RH ???
8810 Set_Assignment_OK
(Ref
);
8813 -- If the underlying_type is a subtype, then we are dealing with the
8814 -- completion of a private type. We need to access the base type and
8815 -- generate a conversion to it.
8817 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8818 pragma Assert
(Is_Private_Type
(Typ
));
8819 Utyp
:= Base_Type
(Utyp
);
8820 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8823 -- The underlying type may not be present due to a missing full view.
8824 -- In this case freezing did not take place and there is no suitable
8825 -- [Deep_]Initialize primitive to call.
8826 -- If Typ is protected then no additional processing is needed either.
8829 or else Is_Protected_Type
(Typ
)
8834 -- Select the appropriate version of initialize
8836 if Has_Controlled_Component
(Utyp
) then
8837 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8839 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8840 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8843 -- If initialization procedure for an array of controlled objects is
8844 -- trivial, do not generate a useless call to it.
8845 -- The initialization procedure may be missing altogether in the case
8846 -- of a derived container whose components have trivial initialization.
8849 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8851 (not Comes_From_Source
(Proc
)
8852 and then Present
(Alias
(Proc
))
8853 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8858 -- The object reference may need another conversion depending on the
8859 -- type of the formal and that of the actual.
8861 Ref
:= Convert_View
(Proc
, Ref
);
8864 -- [Deep_]Initialize (Ref);
8867 Make_Procedure_Call_Statement
(Loc
,
8868 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8869 Parameter_Associations
=> New_List
(Ref
));
8872 ------------------------------
8873 -- Make_Local_Deep_Finalize --
8874 ------------------------------
8876 function Make_Local_Deep_Finalize
8878 Nam
: Entity_Id
) return Node_Id
8880 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8884 Formals
:= New_List
(
8888 Make_Parameter_Specification
(Loc
,
8889 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8891 Out_Present
=> True,
8892 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8894 -- F : Boolean := True
8896 Make_Parameter_Specification
(Loc
,
8897 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8898 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8899 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8901 -- Add the necessary number of counters to represent the initialization
8902 -- state of an object.
8905 Make_Subprogram_Body
(Loc
,
8907 Make_Procedure_Specification
(Loc
,
8908 Defining_Unit_Name
=> Nam
,
8909 Parameter_Specifications
=> Formals
),
8911 Declarations
=> No_List
,
8913 Handled_Statement_Sequence
=>
8914 Make_Handled_Sequence_Of_Statements
(Loc
,
8915 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8916 end Make_Local_Deep_Finalize
;
8918 ------------------------------------
8919 -- Make_Set_Finalize_Address_Call --
8920 ------------------------------------
8922 function Make_Set_Finalize_Address_Call
8924 Ptr_Typ
: Entity_Id
) return Node_Id
8926 -- It is possible for Ptr_Typ to be a partial view, if the access type
8927 -- is a full view declared in the private part of a nested package, and
8928 -- the finalization actions take place when completing analysis of the
8929 -- enclosing unit. For this reason use Underlying_Type twice below.
8931 Desig_Typ
: constant Entity_Id
:=
8933 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8934 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8935 Fin_Mas
: constant Entity_Id
:=
8936 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8939 -- Both the finalization master and primitive Finalize_Address must be
8942 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8945 -- Set_Finalize_Address
8946 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8949 Make_Procedure_Call_Statement
(Loc
,
8951 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8952 Parameter_Associations
=> New_List
(
8953 New_Occurrence_Of
(Fin_Mas
, Loc
),
8955 Make_Attribute_Reference
(Loc
,
8956 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8957 Attribute_Name
=> Name_Unrestricted_Access
)));
8958 end Make_Set_Finalize_Address_Call
;
8960 --------------------------
8961 -- Make_Transient_Block --
8962 --------------------------
8964 function Make_Transient_Block
8967 Par
: Node_Id
) return Node_Id
8969 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8970 -- Determine whether scoping entity Id manages the secondary stack
8972 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
8973 -- Return True when N appears within a loop and no block is containing N
8975 -----------------------
8976 -- Manages_Sec_Stack --
8977 -----------------------
8979 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8983 -- An exception handler with a choice parameter utilizes a dummy
8984 -- block to provide a declarative region. Such a block should not
8985 -- be considered because it never manifests in the tree and can
8986 -- never release the secondary stack.
8990 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8997 return Uses_Sec_Stack
(Id
);
9002 end Manages_Sec_Stack
;
9004 ---------------------------
9005 -- Within_Loop_Statement --
9006 ---------------------------
9008 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
9009 Par
: Node_Id
:= Parent
(N
);
9012 while Nkind
(Par
) not in
9013 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9014 N_Package_Specification | N_Proper_Body
9016 pragma Assert
(Present
(Par
));
9017 Par
:= Parent
(Par
);
9020 return Nkind
(Par
) = N_Loop_Statement
;
9021 end Within_Loop_Statement
;
9025 Decls
: constant List_Id
:= New_List
;
9026 Instrs
: constant List_Id
:= New_List
(Action
);
9027 Trans_Id
: constant Entity_Id
:= Current_Scope
;
9033 -- Start of processing for Make_Transient_Block
9036 -- Even though the transient block is tasked with managing the secondary
9037 -- stack, the block may forgo this functionality depending on how the
9038 -- secondary stack is managed by enclosing scopes.
9040 if Manages_Sec_Stack
(Trans_Id
) then
9042 -- Determine whether an enclosing scope already manages the secondary
9045 Scop
:= Scope
(Trans_Id
);
9046 while Present
(Scop
) loop
9048 -- It should not be possible to reach Standard without hitting one
9049 -- of the other cases first unless Standard was manually pushed.
9051 if Scop
= Standard_Standard
then
9054 -- The transient block is within a function which returns on the
9055 -- secondary stack. Take a conservative approach and assume that
9056 -- the value on the secondary stack is part of the result. Note
9057 -- that it is not possible to detect this dependency without flow
9058 -- analysis which the compiler does not have. Letting the object
9059 -- live longer than the transient block will not leak any memory
9060 -- because the caller will reclaim the total storage used by the
9063 elsif Ekind
(Scop
) = E_Function
9064 and then Sec_Stack_Needed_For_Return
(Scop
)
9066 Set_Uses_Sec_Stack
(Trans_Id
, False);
9069 -- The transient block must manage the secondary stack when the
9070 -- block appears within a loop in order to reclaim the memory at
9073 elsif Ekind
(Scop
) = E_Loop
then
9076 -- Ditto when the block appears without a block that does not
9077 -- manage the secondary stack and is located within a loop.
9079 elsif Ekind
(Scop
) = E_Block
9080 and then not Manages_Sec_Stack
(Scop
)
9081 and then Present
(Block_Node
(Scop
))
9082 and then Within_Loop_Statement
(Block_Node
(Scop
))
9086 -- The transient block does not need to manage the secondary stack
9087 -- when there is an enclosing construct which already does that.
9088 -- This optimization saves on SS_Mark and SS_Release calls but may
9089 -- allow objects to live a little longer than required.
9091 -- The transient block must manage the secondary stack when switch
9092 -- -gnatd.s (strict management) is in effect.
9094 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9095 Set_Uses_Sec_Stack
(Trans_Id
, False);
9098 -- Prevent the search from going too far because transient blocks
9099 -- are bounded by packages and subprogram scopes.
9101 elsif Ekind
(Scop
) in E_Entry
9111 Scop
:= Scope
(Scop
);
9115 -- Create the transient block. Set the parent now since the block itself
9116 -- is not part of the tree. The current scope is the E_Block entity that
9117 -- has been pushed by Establish_Transient_Scope.
9119 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9122 Make_Block_Statement
(Loc
,
9123 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9124 Declarations
=> Decls
,
9125 Handled_Statement_Sequence
=>
9126 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9127 Has_Created_Identifier
=> True);
9128 Set_Parent
(Block
, Par
);
9130 -- Insert actions stuck in the transient scopes as well as all freezing
9131 -- nodes needed by those actions. Do not insert cleanup actions here,
9132 -- they will be transferred to the newly created block.
9134 Insert_Actions_In_Scope_Around
9135 (Action
, Clean
=> False, Manage_SS
=> False);
9137 Insert
:= Prev
(Action
);
9139 if Present
(Insert
) then
9140 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9143 -- Transfer cleanup actions to the newly created block
9146 Cleanup_Actions
: List_Id
9147 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9148 Actions_To_Be_Wrapped
(Cleanup
);
9150 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9151 Cleanup_Actions
:= No_List
;
9154 -- When the transient scope was established, we pushed the entry for the
9155 -- transient scope onto the scope stack, so that the scope was active
9156 -- for the installation of finalizable entities etc. Now we must remove
9157 -- this entry, since we have constructed a proper block.
9162 end Make_Transient_Block
;
9164 ------------------------
9165 -- Node_To_Be_Wrapped --
9166 ------------------------
9168 function Node_To_Be_Wrapped
return Node_Id
is
9170 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9171 end Node_To_Be_Wrapped
;
9173 ----------------------------
9174 -- Store_Actions_In_Scope --
9175 ----------------------------
9177 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9178 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9179 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9182 if Is_Empty_List
(Actions
) then
9185 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9186 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9188 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9193 elsif AK
= Before
then
9194 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9197 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9199 end Store_Actions_In_Scope
;
9201 ----------------------------------
9202 -- Store_After_Actions_In_Scope --
9203 ----------------------------------
9205 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9207 Store_Actions_In_Scope
(After
, L
);
9208 end Store_After_Actions_In_Scope
;
9210 -----------------------------------
9211 -- Store_Before_Actions_In_Scope --
9212 -----------------------------------
9214 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9216 Store_Actions_In_Scope
(Before
, L
);
9217 end Store_Before_Actions_In_Scope
;
9219 -----------------------------------
9220 -- Store_Cleanup_Actions_In_Scope --
9221 -----------------------------------
9223 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9225 Store_Actions_In_Scope
(Cleanup
, L
);
9226 end Store_Cleanup_Actions_In_Scope
;
9232 procedure Unnest_Block
(Decl
: Node_Id
) is
9233 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9235 Local_Body
: Node_Id
;
9236 Local_Call
: Node_Id
;
9237 Local_Proc
: Entity_Id
;
9238 Local_Scop
: Entity_Id
;
9241 Local_Scop
:= Entity
(Identifier
(Decl
));
9242 Ent
:= First_Entity
(Local_Scop
);
9244 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9247 Make_Subprogram_Body
(Loc
,
9249 Make_Procedure_Specification
(Loc
,
9250 Defining_Unit_Name
=> Local_Proc
),
9251 Declarations
=> Declarations
(Decl
),
9252 Handled_Statement_Sequence
=>
9253 Handled_Statement_Sequence
(Decl
));
9255 -- Handlers in the block may contain nested subprograms that require
9258 Check_Unnesting_In_Handlers
(Local_Body
);
9260 Rewrite
(Decl
, Local_Body
);
9262 Set_Has_Nested_Subprogram
(Local_Proc
);
9265 Make_Procedure_Call_Statement
(Loc
,
9266 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9268 Insert_After
(Decl
, Local_Call
);
9269 Analyze
(Local_Call
);
9271 -- The new subprogram has the same scope as the original block
9273 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9275 -- And the entity list of the new procedure is that of the block
9277 Set_First_Entity
(Local_Proc
, Ent
);
9279 -- Reset the scopes of all the entities to the new procedure
9281 while Present
(Ent
) loop
9282 Set_Scope
(Ent
, Local_Proc
);
9287 -------------------------
9288 -- Unnest_If_Statement --
9289 -------------------------
9291 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
9293 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
9294 -- A list of statements (that may be a list associated with a then,
9295 -- elsif, or else part of an if-statement) is traversed at the top
9296 -- level to determine whether it contains a subprogram body, and if so,
9297 -- the statements will be replaced with a new procedure body containing
9298 -- the statements followed by a call to the procedure. The individual
9299 -- statements may also be blocks, loops, or other if statements that
9300 -- themselves may require contain nested subprograms needing unnesting.
9302 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
9303 Subp_Found
: Boolean := False;
9306 if Is_Empty_List
(Stmts
) then
9311 Stmt
: Node_Id
:= First
(Stmts
);
9313 while Present
(Stmt
) loop
9314 if Nkind
(Stmt
) = N_Subprogram_Body
then
9323 -- The statements themselves may be blocks, loops, etc. that in turn
9324 -- contain nested subprograms requiring an unnesting transformation.
9325 -- We perform this traversal after looking for subprogram bodies, to
9326 -- avoid considering procedures created for one of those statements
9327 -- (such as a block rewritten as a procedure) as a nested subprogram
9328 -- of the statement list (which could result in an unneeded wrapper
9331 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
9333 -- If there was a top-level subprogram body in the statement list,
9334 -- then perform an unnesting transformation on the list by replacing
9335 -- the statements with a wrapper procedure body containing the
9336 -- original statements followed by a call to that procedure.
9339 Unnest_Statement_List
(Stmts
);
9341 end Check_Stmts_For_Subp_Unnesting
;
9345 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
9346 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
9348 -- Start of processing for Unnest_If_Statement
9351 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
9352 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
9354 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
9356 Elsif_Part
: Node_Id
:=
9357 First
(Elsif_Parts
(If_Stmt
));
9358 Elsif_Stmts
: List_Id
;
9360 while Present
(Elsif_Part
) loop
9361 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
9363 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
9364 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
9371 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
9372 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
9373 end Unnest_If_Statement
;
9379 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
9381 procedure Fixup_Inner_Scopes
(Loop_Stmt
: Node_Id
);
9382 -- The loops created by the compiler for array aggregates can have
9383 -- nested finalization procedure when the type of the array components
9384 -- needs finalization. It has the following form:
9386 -- for J4b in 10 .. 12 loop
9388 -- procedure __finalizer;
9390 -- procedure __finalizer is
9394 -- obj (J4b) := ...;
9396 -- When the compiler creates the N_Block_Statement, it sets its scope to
9397 -- the upper scope (the one containing the loop).
9399 -- The Unnest_Loop procedure moves the N_Loop_Statement inside a new
9400 -- procedure and correctly sets the scopes for both the new procedure
9401 -- and the loop entity. The inner block scope is not modified and this
9402 -- leaves the Tree in an incoherent state (i.e. the inner procedure must
9403 -- have its enclosing procedure in its scope ancestries).
9405 -- This procedure fixes the scope links.
9407 -- Another (better) fix would be to have the block scope set to be the
9408 -- loop entity earlier (when the block is created or when the loop gets
9409 -- an actual entity set). But unfortunately this proved harder to
9412 procedure Fixup_Inner_Scopes
(Loop_Stmt
: Node_Id
) is
9413 Stmt
: Node_Id
:= First
(Statements
(Loop_Stmt
));
9414 Loop_Stmt_Ent
: constant Entity_Id
:= Entity
(Identifier
(Loop_Stmt
));
9415 Ent_To_Fix
: Entity_Id
;
9417 while Present
(Stmt
) loop
9418 if Nkind
(Stmt
) = N_Block_Statement
9419 and then Is_Abort_Block
(Stmt
)
9421 Ent_To_Fix
:= Entity
(Identifier
(Stmt
));
9422 Set_Scope
(Ent_To_Fix
, Loop_Stmt_Ent
);
9423 elsif Nkind
(Stmt
) = N_Loop_Statement
then
9424 Fixup_Inner_Scopes
(Stmt
);
9428 end Fixup_Inner_Scopes
;
9430 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
9432 Local_Body
: Node_Id
;
9433 Local_Call
: Node_Id
;
9434 Loop_Ent
: Entity_Id
;
9435 Local_Proc
: Entity_Id
;
9436 Loop_Copy
: constant Node_Id
:=
9437 Relocate_Node
(Loop_Stmt
);
9439 Loop_Ent
:= Entity
(Identifier
(Loop_Stmt
));
9440 Ent
:= First_Entity
(Loop_Ent
);
9442 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9445 Make_Subprogram_Body
(Loc
,
9447 Make_Procedure_Specification
(Loc
,
9448 Defining_Unit_Name
=> Local_Proc
),
9449 Declarations
=> Empty_List
,
9450 Handled_Statement_Sequence
=>
9451 Make_Handled_Sequence_Of_Statements
(Loc
,
9452 Statements
=> New_List
(Loop_Copy
)));
9454 Rewrite
(Loop_Stmt
, Local_Body
);
9455 Analyze
(Loop_Stmt
);
9457 Set_Has_Nested_Subprogram
(Local_Proc
);
9460 Make_Procedure_Call_Statement
(Loc
,
9461 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9463 Insert_After
(Loop_Stmt
, Local_Call
);
9464 Analyze
(Local_Call
);
9466 -- New procedure has the same scope as the original loop, and the scope
9467 -- of the loop is the new procedure.
9469 Set_Scope
(Local_Proc
, Scope
(Loop_Ent
));
9470 Set_Scope
(Loop_Ent
, Local_Proc
);
9472 Fixup_Inner_Scopes
(Loop_Copy
);
9474 -- The entity list of the new procedure is that of the loop
9476 Set_First_Entity
(Local_Proc
, Ent
);
9478 -- Note that the entities associated with the loop don't need to have
9479 -- their Scope fields reset, since they're still associated with the
9480 -- same loop entity that now belongs to the copied loop statement.
9483 ---------------------------
9484 -- Unnest_Statement_List --
9485 ---------------------------
9487 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
9488 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
9489 Local_Body
: Node_Id
;
9490 Local_Call
: Node_Id
;
9491 Local_Proc
: Entity_Id
;
9492 New_Stmts
: constant List_Id
:= Empty_List
;
9495 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9498 Make_Subprogram_Body
(Loc
,
9500 Make_Procedure_Specification
(Loc
,
9501 Defining_Unit_Name
=> Local_Proc
),
9502 Declarations
=> Empty_List
,
9503 Handled_Statement_Sequence
=>
9504 Make_Handled_Sequence_Of_Statements
(Loc
,
9505 Statements
=> Stmts
));
9507 Append_To
(New_Stmts
, Local_Body
);
9509 Analyze
(Local_Body
);
9511 Set_Has_Nested_Subprogram
(Local_Proc
);
9514 Make_Procedure_Call_Statement
(Loc
,
9515 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9517 Append_To
(New_Stmts
, Local_Call
);
9518 Analyze
(Local_Call
);
9520 -- Traverse the statements, and for any that are declarations or
9521 -- subprogram bodies that have entities, set the Scope of those
9522 -- entities to the new procedure's Entity_Id.
9525 Stmt
: Node_Id
:= First
(Stmts
);
9528 while Present
(Stmt
) loop
9529 case Nkind
(Stmt
) is
9531 | N_Renaming_Declaration
9533 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
9535 when N_Subprogram_Body
=>
9537 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
9548 end Unnest_Statement_List
;
9550 --------------------------------
9551 -- Wrap_Transient_Declaration --
9552 --------------------------------
9554 -- If a transient scope has been established during the processing of the
9555 -- Expression of an Object_Declaration, it is not possible to wrap the
9556 -- declaration into a transient block as usual case, otherwise the object
9557 -- would be itself declared in the wrong scope. Therefore, all entities (if
9558 -- any) defined in the transient block are moved to the proper enclosing
9559 -- scope. Furthermore, if they are controlled variables they are finalized
9560 -- right after the declaration. The finalization list of the transient
9561 -- scope is defined as a renaming of the enclosing one so during their
9562 -- initialization they will be attached to the proper finalization list.
9563 -- For instance, the following declaration :
9565 -- X : Typ := F (G (A), G (B));
9567 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9568 -- is expanded into :
9570 -- X : Typ := [ complex Expression-Action ];
9571 -- [Deep_]Finalize (_v1);
9572 -- [Deep_]Finalize (_v2);
9574 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9579 Curr_S
:= Current_Scope
;
9580 Encl_S
:= Scope
(Curr_S
);
9582 -- Insert all actions including cleanup generated while analyzing or
9583 -- expanding the transient context back into the tree. Manage the
9584 -- secondary stack when the object declaration appears in a library
9585 -- level package [body].
9587 Insert_Actions_In_Scope_Around
9591 Uses_Sec_Stack
(Curr_S
)
9592 and then Nkind
(N
) = N_Object_Declaration
9593 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
9594 and then Is_Library_Level_Entity
(Encl_S
));
9597 -- Relocate local entities declared within the transient scope to the
9598 -- enclosing scope. This action sets their Is_Public flag accordingly.
9600 Transfer_Entities
(Curr_S
, Encl_S
);
9602 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9603 -- is properly released upon exiting the said scope.
9605 if Uses_Sec_Stack
(Curr_S
) then
9606 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9608 -- Do not mark a function that returns on the secondary stack as the
9609 -- reclamation is done by the caller.
9611 if Ekind
(Curr_S
) = E_Function
9612 and then Needs_Secondary_Stack
(Etype
(Curr_S
))
9616 -- Otherwise mark the enclosing dynamic scope
9619 Set_Uses_Sec_Stack
(Curr_S
);
9620 Check_Restriction
(No_Secondary_Stack
, N
);
9623 end Wrap_Transient_Declaration
;
9625 -------------------------------
9626 -- Wrap_Transient_Expression --
9627 -------------------------------
9629 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9630 Loc
: constant Source_Ptr
:= Sloc
(N
);
9631 Expr
: Node_Id
:= Relocate_Node
(N
);
9632 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9633 Typ
: constant Entity_Id
:= Etype
(N
);
9640 -- M : constant Mark_Id := SS_Mark;
9641 -- procedure Finalizer is ... (See Build_Finalizer)
9644 -- Temp := <Expr>; -- general case
9645 -- Temp := (if <Expr> then True else False); -- boolean case
9651 -- A special case is made for Boolean expressions so that the back end
9652 -- knows to generate a conditional branch instruction, if running with
9653 -- -fpreserve-control-flow. This ensures that a control-flow change
9654 -- signaling the decision outcome occurs before the cleanup actions.
9656 if Opt
.Suppress_Control_Flow_Optimizations
9657 and then Is_Boolean_Type
(Typ
)
9660 Make_If_Expression
(Loc
,
9661 Expressions
=> New_List
(
9663 New_Occurrence_Of
(Standard_True
, Loc
),
9664 New_Occurrence_Of
(Standard_False
, Loc
)));
9667 Insert_Actions
(N
, New_List
(
9668 Make_Object_Declaration
(Loc
,
9669 Defining_Identifier
=> Temp
,
9670 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9672 Make_Transient_Block
(Loc
,
9674 Make_Assignment_Statement
(Loc
,
9675 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9676 Expression
=> Expr
),
9677 Par
=> Parent
(N
))));
9679 if Debug_Generated_Code
then
9680 Set_Debug_Info_Needed
(Temp
);
9683 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9684 Analyze_And_Resolve
(N
, Typ
);
9685 end Wrap_Transient_Expression
;
9687 ------------------------------
9688 -- Wrap_Transient_Statement --
9689 ------------------------------
9691 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9692 Loc
: constant Source_Ptr
:= Sloc
(N
);
9693 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9698 -- M : constant Mark_Id := SS_Mark;
9699 -- procedure Finalizer is ... (See Build_Finalizer)
9709 Make_Transient_Block
(Loc
,
9711 Par
=> Parent
(N
)));
9713 -- With the scope stack back to normal, we can call analyze on the
9714 -- resulting block. At this point, the transient scope is being
9715 -- treated like a perfectly normal scope, so there is nothing
9716 -- special about it.
9718 -- Note: Wrap_Transient_Statement is called with the node already
9719 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9720 -- otherwise we would get a recursive processing of the node when
9721 -- we do this Analyze call.
9724 end Wrap_Transient_Statement
;