1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Einfo
.Entities
; use Einfo
.Entities
;
34 with Einfo
.Utils
; use Einfo
.Utils
;
35 with Elists
; use Elists
;
36 with Errout
; use Errout
;
37 with Exp_Ch6
; use Exp_Ch6
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Ch11
; use Exp_Ch11
;
40 with Exp_Dbug
; use Exp_Dbug
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Disp
; use Exp_Disp
;
43 with Exp_Prag
; use Exp_Prag
;
44 with Exp_Tss
; use Exp_Tss
;
45 with Exp_Util
; use Exp_Util
;
46 with Freeze
; use Freeze
;
47 with GNAT_CUDA
; use GNAT_CUDA
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Output
; use Output
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
58 with Sinfo
.Utils
; use Sinfo
.Utils
;
60 with Sem_Aux
; use Sem_Aux
;
61 with Sem_Ch7
; use Sem_Ch7
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Snames
; use Snames
;
66 with Stand
; use Stand
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Uintp
; use Uintp
;
71 package body Exp_Ch7
is
73 --------------------------------
74 -- Transient Scope Management --
75 --------------------------------
77 -- A transient scope is needed when certain temporary objects are created
78 -- by the compiler. These temporary objects are allocated on the secondary
79 -- stack and/or need finalization, and the transient scope is responsible
80 -- for finalizing the objects and reclaiming the memory of the secondary
81 -- stack at the appropriate time. They are generally objects allocated to
82 -- store the result of a function returning an unconstrained or controlled
83 -- value. Expressions needing to be wrapped in a transient scope may appear
84 -- in three different contexts which lead to different kinds of transient
87 -- 1. In a simple statement (procedure call, assignment, ...). In this
88 -- case the instruction is wrapped into a transient block. See
89 -- Wrap_Transient_Statement for details.
91 -- 2. In an expression of a control structure (test in a IF statement,
92 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
95 -- 3. In a expression of an object_declaration. No wrapping is possible
96 -- here, so the finalization actions, if any, are done right after the
97 -- declaration and the secondary stack deallocation is done in the
98 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
100 --------------------------------------------------
101 -- Transient Blocks and Finalization Management --
102 --------------------------------------------------
104 procedure Insert_Actions_In_Scope_Around
107 Manage_SS
: Boolean);
108 -- Insert the before-actions kept in the scope stack before N, and the
109 -- after-actions after N, which must be a member of a list. If flag Clean
110 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
111 -- calls to mark and release the secondary stack.
113 function Make_Transient_Block
116 Par
: Node_Id
) return Node_Id
;
117 -- Action is a single statement or object declaration. Par is the proper
118 -- parent of the generated block. Create a transient block whose name is
119 -- the current scope and the only handled statement is Action. If Action
120 -- involves controlled objects or secondary stack usage, the corresponding
121 -- cleanup actions are performed at the end of the block.
123 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
124 -- Shared processing for Store_xxx_Actions_In_Scope
126 -----------------------------
127 -- Finalization Management --
128 -----------------------------
130 -- This part describes how Initialization/Adjustment/Finalization
131 -- procedures are generated and called. Two cases must be considered: types
132 -- that are Controlled (Is_Controlled flag set) and composite types that
133 -- contain controlled components (Has_Controlled_Component flag set). In
134 -- the first case the procedures to call are the user-defined primitive
135 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
136 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
137 -- charge of calling the former procedures on the controlled components.
139 -- For records with Has_Controlled_Component set, a hidden "controller"
140 -- component is inserted. This controller component contains its own
141 -- finalization list on which all controlled components are attached
142 -- creating an indirection on the upper-level Finalization list. This
143 -- technique facilitates the management of objects whose number of
144 -- controlled components changes during execution. This controller
145 -- component is itself controlled and is attached to the upper-level
146 -- finalization chain. Its adjust primitive is in charge of calling adjust
147 -- on the components and adjusting the finalization pointer to match their
148 -- new location (see a-finali.adb).
150 -- It is not possible to use a similar technique for arrays that have
151 -- Has_Controlled_Component set. In this case, deep procedures are
152 -- generated that call initialize/adjust/finalize + attachment or
153 -- detachment on the finalization list for all component.
155 -- Initialize calls: they are generated for declarations or dynamic
156 -- allocations of Controlled objects with no initial value. They are always
157 -- followed by an attachment to the current Finalization Chain. For the
158 -- dynamic allocation case this the chain attached to the scope of the
159 -- access type definition otherwise, this is the chain of the current
162 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
163 -- or dynamic allocations of Controlled objects with an initial value.
164 -- (2) after an assignment. In the first case they are followed by an
165 -- attachment to the final chain, in the second case they are not.
167 -- Finalization Calls: They are generated on (1) scope exit, (2)
168 -- assignments, (3) unchecked deallocations. In case (3) they have to
169 -- be detached from the final chain, in case (2) they must not and in
170 -- case (1) this is not important since we are exiting the scope anyway.
174 -- Type extensions will have a new record controller at each derivation
175 -- level containing controlled components. The record controller for
176 -- the parent/ancestor is attached to the finalization list of the
177 -- extension's record controller (i.e. the parent is like a component
178 -- of the extension).
180 -- For types that are both Is_Controlled and Has_Controlled_Components,
181 -- the record controller and the object itself are handled separately.
182 -- It could seem simpler to attach the object at the end of its record
183 -- controller but this would not tackle view conversions properly.
185 -- A classwide type can always potentially have controlled components
186 -- but the record controller of the corresponding actual type may not
187 -- be known at compile time so the dispatch table contains a special
188 -- field that allows computation of the offset of the record controller
189 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
191 -- Here is a simple example of the expansion of a controlled block :
195 -- Y : Controlled := Init;
201 -- Z : R := (C => X);
211 -- _L : System.FI.Finalizable_Ptr;
213 -- procedure _Clean is
216 -- System.FI.Finalize_List (_L);
224 -- Attach_To_Final_List (_L, Finalizable (X), 1);
225 -- at end: Abort_Undefer;
226 -- Y : Controlled := Init;
228 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
236 -- Deep_Initialize (W, _L, 1);
237 -- at end: Abort_Under;
238 -- Z : R := (C => X);
239 -- Deep_Adjust (Z, _L, 1);
243 -- Deep_Finalize (W, False);
244 -- <save W's final pointers>
246 -- <restore W's final pointers>
247 -- Deep_Adjust (W, _L, 0);
252 type Final_Primitives
is
253 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
254 -- This enumeration type is defined in order to ease sharing code for
255 -- building finalization procedures for composite types.
257 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
258 (Initialize_Case
=> Name_Initialize
,
259 Adjust_Case
=> Name_Adjust
,
260 Finalize_Case
=> Name_Finalize
,
261 Address_Case
=> Name_Finalize_Address
);
262 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
263 (Initialize_Case
=> TSS_Deep_Initialize
,
264 Adjust_Case
=> TSS_Deep_Adjust
,
265 Finalize_Case
=> TSS_Deep_Finalize
,
266 Address_Case
=> TSS_Finalize_Address
);
268 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
269 -- Determine whether access type Typ may have a finalization master
271 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
272 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
273 -- Has_Controlled_Component set and store them using the TSS mechanism.
275 function Build_Cleanup_Statements
277 Additional_Cleanup
: List_Id
) return List_Id
;
278 -- Create the cleanup calls for an asynchronous call block, task master,
279 -- protected subprogram body, task allocation block or task body, or
280 -- additional cleanup actions parked on a transient block. If the context
281 -- does not contain the above constructs, the routine returns an empty
284 procedure Build_Finalizer
286 Clean_Stmts
: List_Id
;
289 Defer_Abort
: Boolean;
290 Fin_Id
: out Entity_Id
);
291 -- N may denote an accept statement, block, entry body, package body,
292 -- package spec, protected body, subprogram body, or a task body. Create
293 -- a procedure which contains finalization calls for all controlled objects
294 -- declared in the declarative or statement region of N. The calls are
295 -- built in reverse order relative to the original declarations. In the
296 -- case of a task body, the routine delays the creation of the finalizer
297 -- until all statements have been moved to the task body procedure.
298 -- Clean_Stmts may contain additional context-dependent code used to abort
299 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
300 -- Mark_Id is the secondary stack used in the current context or Empty if
301 -- missing. Top_Decls is the list on which the declaration of the finalizer
302 -- is attached in the non-package case. Defer_Abort indicates that the
303 -- statements passed in perform actions that require abort to be deferred,
304 -- such as for task termination. Fin_Id is the finalizer declaration
307 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
308 -- N is a construct that contains a handled sequence of statements, Fin_Id
309 -- is the entity of a finalizer. Create an At_End handler that covers the
310 -- statements of N and calls Fin_Id. If the handled statement sequence has
311 -- an exception handler, the statements will be wrapped in a block to avoid
312 -- unwanted interaction with the new At_End handler.
314 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
315 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
316 -- Has_Component_Component set and store them using the TSS mechanism.
318 -------------------------------------------
319 -- Unnesting procedures for CCG and LLVM --
320 -------------------------------------------
322 -- Expansion generates subprograms for controlled types management that
323 -- may appear in declarative lists in package declarations and bodies.
324 -- These subprograms appear within generated blocks that contain local
325 -- declarations and a call to finalization procedures. To ensure that
326 -- such subprograms get activation records when needed, we transform the
327 -- block into a procedure body, followed by a call to it in the same
330 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
331 -- The statement part of a package body that is a compilation unit may
332 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
333 -- Mode such subprograms must be handled as nested inside the (implicit)
334 -- elaboration procedure that executes that statement part. To handle
335 -- properly uplevel references we construct that subprogram explicitly,
336 -- to contain blocks and inner subprograms, the statement part becomes
337 -- a call to this subprogram. This is only done if blocks are present
338 -- in the statement list of the body. (It would be nice to unify this
339 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
340 -- they're doing very similar work, but are structured differently. ???)
342 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
343 -- Similarly, the declarations or statements in library-level packages may
344 -- have created blocks with nested subprograms. Such a block must be
345 -- transformed into a procedure followed by a call to it, so that unnesting
346 -- can handle uplevel references within these nested subprograms (typically
347 -- subprograms that handle finalization actions). This also applies to
348 -- nested packages, including instantiations, in which case it must
349 -- recursively process inner bodies.
351 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
352 -- Similarly, check for blocks with nested subprograms occurring within
353 -- a set of exception handlers associated with a package body N.
355 procedure Unnest_Block
(Decl
: Node_Id
);
356 -- Blocks that contain nested subprograms with up-level references need to
357 -- create activation records for them. We do this by rewriting the block as
358 -- a procedure, followed by a call to it in the same declarative list, to
359 -- replicate the semantics of the original block.
361 -- A common source for such block is a transient block created for a
362 -- construct (declaration, assignment, etc.) that involves controlled
363 -- actions or secondary-stack management, in which case the nested
364 -- subprogram is a finalizer.
366 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
367 -- The separate statement lists associated with an if-statement (then part,
368 -- elsif parts, else part) may require unnesting if they directly contain
369 -- a subprogram body that references up-level objects. Each statement list
370 -- is traversed to locate such subprogram bodies, and if a part's statement
371 -- list contains a body, then the list is replaced with a new procedure
372 -- containing the part's statements followed by a call to the procedure.
373 -- Furthermore, any nested blocks, loops, or if statements will also be
374 -- traversed to determine the need for further unnesting transformations.
376 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
377 -- A list of statements that directly contains a subprogram at its outer
378 -- level, that may reference objects declared in that same statement list,
379 -- is rewritten as a procedure containing the statement list Stmts (which
380 -- includes any such objects as well as the nested subprogram), followed by
381 -- a call to the new procedure, and Stmts becomes the list containing the
382 -- procedure and the call. This ensures that Unnest_Subprogram will later
383 -- properly handle up-level references from the nested subprogram to
384 -- objects declared earlier in statement list, by creating an activation
385 -- record and passing it to the nested subprogram. This procedure also
386 -- resets the Scope of objects declared in the statement list, as well as
387 -- the Scope of the nested subprogram, to refer to the new procedure.
388 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
389 -- only be called when known that the statement list contains a subprogram.
391 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
392 -- Top-level Loops that contain nested subprograms with up-level references
393 -- need to have activation records. We do this by rewriting the loop as a
394 -- procedure containing the loop, followed by a call to the procedure in
395 -- the same library-level declarative list, to replicate the semantics of
396 -- the original loop. Such loops can occur due to aggregate expansions and
399 procedure Check_Visibly_Controlled
400 (Prim
: Final_Primitives
;
402 E
: in out Entity_Id
;
403 Cref
: in out Node_Id
);
404 -- The controlled operation declared for a derived type may not be
405 -- overriding, if the controlled operations of the parent type are hidden,
406 -- for example when the parent is a private type whose full view is
407 -- controlled. For other primitive operations we modify the name of the
408 -- operation to indicate that it is not overriding, but this is not
409 -- possible for Initialize, etc. because they have to be retrievable by
410 -- name. Before generating the proper call to one of these operations we
411 -- check whether Typ is known to be controlled at the point of definition.
412 -- If it is not then we must retrieve the hidden operation of the parent
413 -- and use it instead. This is one case that might be solved more cleanly
414 -- once Overriding pragmas or declarations are in place.
416 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
417 -- Check recursively whether a loop or block contains a subprogram that
418 -- may need an activation record.
420 function Convert_View
423 Ind
: Pos
:= 1) return Node_Id
;
424 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
425 -- argument being passed to it. Ind indicates which formal of procedure
426 -- Proc we are trying to match. This function will, if necessary, generate
427 -- a conversion between the partial and full view of Arg to match the type
428 -- of the formal of Proc, or force a conversion to the class-wide type in
429 -- the case where the operation is abstract.
435 Skip_Self
: Boolean := False) return Node_Id
;
436 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
437 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
438 -- an adjust or finalization call. When flag Skip_Self is set, the related
439 -- action has an effect on the components only (if any).
441 function Make_Deep_Proc
442 (Prim
: Final_Primitives
;
444 Stmts
: List_Id
) return Entity_Id
;
445 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
446 -- Deep_Finalize procedures according to the first parameter. These
447 -- procedures operate on the type Typ. The Stmts parameter gives the
448 -- body of the procedure.
450 function Make_Deep_Array_Body
451 (Prim
: Final_Primitives
;
452 Typ
: Entity_Id
) return List_Id
;
453 -- This function generates the list of statements for implementing
454 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
455 -- the first parameter, these procedures operate on the array type Typ.
457 function Make_Deep_Record_Body
458 (Prim
: Final_Primitives
;
460 Is_Local
: Boolean := False) return List_Id
;
461 -- This function generates the list of statements for implementing
462 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
463 -- the first parameter, these procedures operate on the record type Typ.
464 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
465 -- whether the inner logic should be dictated by state counters.
467 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
468 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
469 -- Make_Deep_Record_Body. Generate the following statements:
472 -- type Acc_Typ is access all Typ;
473 -- for Acc_Typ'Storage_Size use 0;
475 -- [Deep_]Finalize (Acc_Typ (V).all);
478 --------------------------------
479 -- Allows_Finalization_Master --
480 --------------------------------
482 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
483 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
484 -- Determine whether entity E is inside a wrapper package created for
485 -- an instance of Ada.Unchecked_Deallocation.
487 ------------------------------
488 -- In_Deallocation_Instance --
489 ------------------------------
491 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
492 Pkg
: constant Entity_Id
:= Scope
(E
);
493 Par
: Node_Id
:= Empty
;
496 if Ekind
(Pkg
) = E_Package
497 and then Present
(Related_Instance
(Pkg
))
498 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
500 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
504 and then Chars
(Par
) = Name_Unchecked_Deallocation
505 and then Chars
(Scope
(Par
)) = Name_Ada
506 and then Scope
(Scope
(Par
)) = Standard_Standard
;
510 end In_Deallocation_Instance
;
514 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
515 Ptr_Typ
: constant Entity_Id
:=
516 Root_Type_Of_Full_View
(Base_Type
(Typ
));
518 -- Start of processing for Allows_Finalization_Master
521 -- Certain run-time configurations and targets do not provide support
522 -- for controlled types and therefore do not need masters.
524 if Restriction_Active
(No_Finalization
) then
527 -- Do not consider C and C++ types since it is assumed that the non-Ada
528 -- side will handle their cleanup.
530 elsif Convention
(Desig_Typ
) = Convention_C
531 or else Convention
(Desig_Typ
) = Convention_CPP
535 -- Do not consider an access type that returns on the secondary stack
537 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
538 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
542 -- Do not consider an access type that can never allocate an object
544 elsif No_Pool_Assigned
(Ptr_Typ
) then
547 -- Do not consider an access type coming from an Unchecked_Deallocation
548 -- instance. Even though the designated type may be controlled, the
549 -- access type will never participate in any allocations.
551 elsif In_Deallocation_Instance
(Ptr_Typ
) then
554 -- Do not consider a non-library access type when No_Nested_Finalization
555 -- is in effect since finalization masters are controlled objects and if
556 -- created will violate the restriction.
558 elsif Restriction_Active
(No_Nested_Finalization
)
559 and then not Is_Library_Level_Entity
(Ptr_Typ
)
563 -- Do not consider an access type subject to pragma No_Heap_Finalization
564 -- because objects allocated through such a type are not to be finalized
565 -- when the access type goes out of scope.
567 elsif No_Heap_Finalization
(Ptr_Typ
) then
570 -- Do not create finalization masters in GNATprove mode because this
571 -- causes unwanted extra expansion. A compilation in this mode must
572 -- keep the tree as close as possible to the original sources.
574 elsif GNATprove_Mode
then
577 -- Otherwise the access type may use a finalization master
582 end Allows_Finalization_Master
;
584 ----------------------------
585 -- Build_Anonymous_Master --
586 ----------------------------
588 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
589 function Create_Anonymous_Master
590 (Desig_Typ
: Entity_Id
;
592 Unit_Decl
: Node_Id
) return Entity_Id
;
593 -- Create a new anonymous master for access type Ptr_Typ with designated
594 -- type Desig_Typ. The declaration of the master and its initialization
595 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
596 -- the entity of Unit_Decl.
598 function Current_Anonymous_Master
599 (Desig_Typ
: Entity_Id
;
600 Unit_Id
: Entity_Id
) return Entity_Id
;
601 -- Find an anonymous master declared within unit Unit_Id which services
602 -- designated type Desig_Typ. If there is no such master, return Empty.
604 -----------------------------
605 -- Create_Anonymous_Master --
606 -----------------------------
608 function Create_Anonymous_Master
609 (Desig_Typ
: Entity_Id
;
611 Unit_Decl
: Node_Id
) return Entity_Id
613 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
624 -- <FM_Id> : Finalization_Master;
626 FM_Id
:= Make_Temporary
(Loc
, 'A');
629 Make_Object_Declaration
(Loc
,
630 Defining_Identifier
=> FM_Id
,
632 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
636 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
639 Make_Procedure_Call_Statement
(Loc
,
641 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
642 Parameter_Associations
=> New_List
(
643 New_Occurrence_Of
(FM_Id
, Loc
),
644 Make_Attribute_Reference
(Loc
,
646 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
647 Attribute_Name
=> Name_Unrestricted_Access
)));
649 -- Find the declarative list of the unit
651 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
652 Unit_Spec
:= Specification
(Unit_Decl
);
653 Decls
:= Visible_Declarations
(Unit_Spec
);
657 Set_Visible_Declarations
(Unit_Spec
, Decls
);
660 -- Package body or subprogram case
662 -- ??? A subprogram spec or body that acts as a compilation unit may
663 -- contain a formal parameter of an anonymous access-to-controlled
664 -- type initialized by an allocator.
666 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
668 -- There is no suitable place to create the master as the subprogram
669 -- is not in a declarative list.
672 Decls
:= Declarations
(Unit_Decl
);
676 Set_Declarations
(Unit_Decl
, Decls
);
680 Prepend_To
(Decls
, FM_Init
);
681 Prepend_To
(Decls
, FM_Decl
);
683 -- Use the scope of the unit when analyzing the declaration of the
684 -- master and its initialization actions.
686 Push_Scope
(Unit_Id
);
691 -- Mark the master as servicing this specific designated type
693 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
695 -- Include the anonymous master in the list of existing masters which
696 -- appear in this unit. This effectively creates a mapping between a
697 -- master and a designated type which in turn allows for the reuse of
698 -- masters on a per-unit basis.
700 All_FMs
:= Anonymous_Masters
(Unit_Id
);
703 All_FMs
:= New_Elmt_List
;
704 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
707 Prepend_Elmt
(FM_Id
, All_FMs
);
710 end Create_Anonymous_Master
;
712 ------------------------------
713 -- Current_Anonymous_Master --
714 ------------------------------
716 function Current_Anonymous_Master
717 (Desig_Typ
: Entity_Id
;
718 Unit_Id
: Entity_Id
) return Entity_Id
720 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
725 -- Inspect the list of anonymous masters declared within the unit
726 -- looking for an existing master which services the same designated
729 if Present
(All_FMs
) then
730 FM_Elmt
:= First_Elmt
(All_FMs
);
731 while Present
(FM_Elmt
) loop
732 FM_Id
:= Node
(FM_Elmt
);
734 -- The currect master services the same designated type. As a
735 -- result the master can be reused and associated with another
736 -- anonymous access-to-controlled type.
738 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
747 end Current_Anonymous_Master
;
751 Desig_Typ
: Entity_Id
;
753 Priv_View
: Entity_Id
;
757 -- Start of processing for Build_Anonymous_Master
760 -- Nothing to do if the circumstances do not allow for a finalization
763 if not Allows_Finalization_Master
(Ptr_Typ
) then
767 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
768 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
770 -- The compilation unit is a package instantiation. In this case the
771 -- anonymous master is associated with the package spec as both the
772 -- spec and body appear at the same level.
774 if Nkind
(Unit_Decl
) = N_Package_Body
775 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
777 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
778 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
781 -- Use the initial declaration of the designated type when it denotes
782 -- the full view of an incomplete or private type. This ensures that
783 -- types with one and two views are treated the same.
785 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
786 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
788 if Present
(Priv_View
) then
789 Desig_Typ
:= Priv_View
;
792 -- Determine whether the current semantic unit already has an anonymous
793 -- master which services the designated type.
795 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
797 -- If this is not the case, create a new master
800 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
803 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
804 end Build_Anonymous_Master
;
806 ----------------------------
807 -- Build_Array_Deep_Procs --
808 ----------------------------
810 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
814 (Prim
=> Initialize_Case
,
816 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
818 if not Is_Limited_View
(Typ
) then
821 (Prim
=> Adjust_Case
,
823 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
826 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
827 -- suppressed since these routine will not be used.
829 if not Restriction_Active
(No_Finalization
) then
832 (Prim
=> Finalize_Case
,
834 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
836 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
838 if not CodePeer_Mode
then
841 (Prim
=> Address_Case
,
843 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
846 end Build_Array_Deep_Procs
;
848 ------------------------------
849 -- Build_Cleanup_Statements --
850 ------------------------------
852 function Build_Cleanup_Statements
854 Additional_Cleanup
: List_Id
) return List_Id
856 Is_Asynchronous_Call
: constant Boolean :=
857 Nkind
(N
) = N_Block_Statement
and then Is_Asynchronous_Call_Block
(N
);
858 Is_Master
: constant Boolean :=
859 Nkind
(N
) /= N_Entry_Body
and then Is_Task_Master
(N
);
860 Is_Protected_Subp_Body
: constant Boolean :=
861 Nkind
(N
) = N_Subprogram_Body
862 and then Is_Protected_Subprogram_Body
(N
);
863 Is_Task_Allocation
: constant Boolean :=
864 Nkind
(N
) = N_Block_Statement
and then Is_Task_Allocation_Block
(N
);
865 Is_Task_Body
: constant Boolean :=
866 Nkind
(Original_Node
(N
)) = N_Task_Body
;
868 Loc
: constant Source_Ptr
:= Sloc
(N
);
869 Stmts
: constant List_Id
:= New_List
;
873 if Restricted_Profile
then
875 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
877 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
881 if Restriction_Active
(No_Task_Hierarchy
) = False then
882 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
885 -- Add statements to unlock the protected object parameter and to
886 -- undefer abort. If the context is a protected procedure and the object
887 -- has entries, call the entry service routine.
889 -- NOTE: The generated code references _object, a parameter to the
892 elsif Is_Protected_Subp_Body
then
894 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
895 Conc_Typ
: Entity_Id
:= Empty
;
897 Param_Typ
: Entity_Id
;
900 -- Find the _object parameter representing the protected object
902 Param
:= First
(Parameter_Specifications
(Spec
));
904 Param_Typ
:= Etype
(Parameter_Type
(Param
));
906 if Ekind
(Param_Typ
) = E_Record_Type
then
907 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
910 exit when No
(Param
) or else Present
(Conc_Typ
);
914 pragma Assert
(Present
(Param
));
915 pragma Assert
(Present
(Conc_Typ
));
917 Build_Protected_Subprogram_Call_Cleanup
918 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
921 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
922 -- tasks. Other unactivated tasks are completed by Complete_Task or
925 -- NOTE: The generated code references _chain, a local object
927 elsif Is_Task_Allocation
then
930 -- Expunge_Unactivated_Tasks (_chain);
932 -- where _chain is the list of tasks created by the allocator but not
933 -- yet activated. This list will be empty unless the block completes
937 Make_Procedure_Call_Statement
(Loc
,
940 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
941 Parameter_Associations
=> New_List
(
942 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
944 -- Attempt to cancel an asynchronous entry call whenever the block which
945 -- contains the abortable part is exited.
947 -- NOTE: The generated code references Cnn, a local object
949 elsif Is_Asynchronous_Call
then
951 Cancel_Param
: constant Entity_Id
:=
952 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
955 -- If it is of type Communication_Block, this must be a protected
956 -- entry call. Generate:
958 -- if Enqueued (Cancel_Param) then
959 -- Cancel_Protected_Entry_Call (Cancel_Param);
962 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
964 Make_If_Statement
(Loc
,
966 Make_Function_Call
(Loc
,
968 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
969 Parameter_Associations
=> New_List
(
970 New_Occurrence_Of
(Cancel_Param
, Loc
))),
972 Then_Statements
=> New_List
(
973 Make_Procedure_Call_Statement
(Loc
,
976 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
977 Parameter_Associations
=> New_List
(
978 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
980 -- Asynchronous delay, generate:
981 -- Cancel_Async_Delay (Cancel_Param);
983 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
985 Make_Procedure_Call_Statement
(Loc
,
987 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
988 Parameter_Associations
=> New_List
(
989 Make_Attribute_Reference
(Loc
,
991 New_Occurrence_Of
(Cancel_Param
, Loc
),
992 Attribute_Name
=> Name_Unchecked_Access
))));
994 -- Task entry call, generate:
995 -- Cancel_Task_Entry_Call (Cancel_Param);
999 Make_Procedure_Call_Statement
(Loc
,
1001 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
1002 Parameter_Associations
=> New_List
(
1003 New_Occurrence_Of
(Cancel_Param
, Loc
))));
1008 Append_List_To
(Stmts
, Additional_Cleanup
);
1010 end Build_Cleanup_Statements
;
1012 -----------------------------
1013 -- Build_Controlling_Procs --
1014 -----------------------------
1016 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
1018 if Is_Array_Type
(Typ
) then
1019 Build_Array_Deep_Procs
(Typ
);
1020 else pragma Assert
(Is_Record_Type
(Typ
));
1021 Build_Record_Deep_Procs
(Typ
);
1023 end Build_Controlling_Procs
;
1025 -----------------------------
1026 -- Build_Exception_Handler --
1027 -----------------------------
1029 function Build_Exception_Handler
1030 (Data
: Finalization_Exception_Data
;
1031 For_Library
: Boolean := False) return Node_Id
1034 Proc_To_Call
: Entity_Id
;
1039 pragma Assert
(Present
(Data
.Raised_Id
));
1041 if Exception_Extra_Info
1042 or else (For_Library
and not Restricted_Profile
)
1044 if Exception_Extra_Info
then
1048 -- Get_Current_Excep.all
1051 Make_Function_Call
(Data
.Loc
,
1053 Make_Explicit_Dereference
(Data
.Loc
,
1056 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1063 Except
:= Make_Null
(Data
.Loc
);
1066 if For_Library
and then not Restricted_Profile
then
1067 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1068 Actuals
:= New_List
(Except
);
1071 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1073 -- The dereference occurs only when Exception_Extra_Info is true,
1074 -- and therefore Except is not null.
1078 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1079 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1085 -- if not Raised_Id then
1086 -- Raised_Id := True;
1088 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1090 -- Save_Library_Occurrence (Get_Current_Excep.all);
1095 Make_If_Statement
(Data
.Loc
,
1097 Make_Op_Not
(Data
.Loc
,
1098 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1100 Then_Statements
=> New_List
(
1101 Make_Assignment_Statement
(Data
.Loc
,
1102 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1103 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1105 Make_Procedure_Call_Statement
(Data
.Loc
,
1107 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1108 Parameter_Associations
=> Actuals
))));
1113 -- Raised_Id := True;
1116 Make_Assignment_Statement
(Data
.Loc
,
1117 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1118 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1126 Make_Exception_Handler
(Data
.Loc
,
1127 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1128 Statements
=> Stmts
);
1129 end Build_Exception_Handler
;
1131 -------------------------------
1132 -- Build_Finalization_Master --
1133 -------------------------------
1135 procedure Build_Finalization_Master
1137 For_Lib_Level
: Boolean := False;
1138 For_Private
: Boolean := False;
1139 Context_Scope
: Entity_Id
:= Empty
;
1140 Insertion_Node
: Node_Id
:= Empty
)
1142 procedure Add_Pending_Access_Type
1144 Ptr_Typ
: Entity_Id
);
1145 -- Add access type Ptr_Typ to the pending access type list for type Typ
1147 -----------------------------
1148 -- Add_Pending_Access_Type --
1149 -----------------------------
1151 procedure Add_Pending_Access_Type
1153 Ptr_Typ
: Entity_Id
)
1158 if Present
(Pending_Access_Types
(Typ
)) then
1159 List
:= Pending_Access_Types
(Typ
);
1161 List
:= New_Elmt_List
;
1162 Set_Pending_Access_Types
(Typ
, List
);
1165 Prepend_Elmt
(Ptr_Typ
, List
);
1166 end Add_Pending_Access_Type
;
1170 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1172 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1173 -- A finalization master created for a named access type is associated
1174 -- with the full view (if applicable) as a consequence of freezing. The
1175 -- full view criteria does not apply to anonymous access types because
1176 -- those cannot have a private and a full view.
1178 -- Start of processing for Build_Finalization_Master
1181 -- Nothing to do if the circumstances do not allow for a finalization
1184 if not Allows_Finalization_Master
(Typ
) then
1187 -- Various machinery such as freezing may have already created a
1188 -- finalization master.
1190 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1195 Actions
: constant List_Id
:= New_List
;
1196 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1197 Fin_Mas_Id
: Entity_Id
;
1198 Pool_Id
: Entity_Id
;
1201 -- Source access types use fixed master names since the master is
1202 -- inserted in the same source unit only once. The only exception to
1203 -- this are instances using the same access type as generic actual.
1205 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1207 Make_Defining_Identifier
(Loc
,
1208 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1210 -- Internally generated access types use temporaries as their names
1211 -- due to possible collision with identical names coming from other
1215 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1218 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1221 -- <Ptr_Typ>FM : aliased Finalization_Master;
1224 Make_Object_Declaration
(Loc
,
1225 Defining_Identifier
=> Fin_Mas_Id
,
1226 Aliased_Present
=> True,
1227 Object_Definition
=>
1228 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1230 if Debug_Generated_Code
then
1231 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1234 -- Set the associated pool and primitive Finalize_Address of the new
1235 -- finalization master.
1237 -- The access type has a user-defined storage pool, use it
1239 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1240 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1242 -- Otherwise the default choice is the global storage pool
1245 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1246 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1250 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1253 Make_Procedure_Call_Statement
(Loc
,
1255 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1256 Parameter_Associations
=> New_List
(
1257 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1258 Make_Attribute_Reference
(Loc
,
1259 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1260 Attribute_Name
=> Name_Unrestricted_Access
))));
1262 -- Finalize_Address is not generated in CodePeer mode because the
1263 -- body contains address arithmetic. Skip this step.
1265 if CodePeer_Mode
then
1268 -- Associate the Finalize_Address primitive of the designated type
1269 -- with the finalization master of the access type. The designated
1270 -- type must be forzen as Finalize_Address is generated when the
1271 -- freeze node is expanded.
1273 elsif Is_Frozen
(Desig_Typ
)
1274 and then Present
(Finalize_Address
(Desig_Typ
))
1276 -- The finalization master of an anonymous access type may need
1277 -- to be inserted in a specific place in the tree. For instance:
1281 -- <finalization master of "access Comp_Typ">
1283 -- type Rec_Typ is record
1284 -- Comp : access Comp_Typ;
1287 -- <freeze node for Comp_Typ>
1288 -- <freeze node for Rec_Typ>
1290 -- Due to this oddity, the anonymous access type is stored for
1291 -- later processing (see below).
1293 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1296 -- Set_Finalize_Address
1297 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1300 Make_Set_Finalize_Address_Call
1302 Ptr_Typ
=> Ptr_Typ
));
1304 -- Otherwise the designated type is either anonymous access or a
1305 -- Taft-amendment type and has not been frozen. Store the access
1306 -- type for later processing (see Freeze_Type).
1309 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1312 -- A finalization master created for an access designating a type
1313 -- with private components is inserted before a context-dependent
1318 -- At this point both the scope of the context and the insertion
1319 -- mode must be known.
1321 pragma Assert
(Present
(Context_Scope
));
1322 pragma Assert
(Present
(Insertion_Node
));
1324 Push_Scope
(Context_Scope
);
1326 -- Treat use clauses as declarations and insert directly in front
1329 if Nkind
(Insertion_Node
) in
1330 N_Use_Package_Clause | N_Use_Type_Clause
1332 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1334 Insert_Actions
(Insertion_Node
, Actions
);
1339 -- The finalization master belongs to an access result type related
1340 -- to a build-in-place function call used to initialize a library
1341 -- level object. The master must be inserted in front of the access
1342 -- result type declaration denoted by Insertion_Node.
1344 elsif For_Lib_Level
then
1345 pragma Assert
(Present
(Insertion_Node
));
1346 Insert_Actions
(Insertion_Node
, Actions
);
1348 -- Otherwise the finalization master and its initialization become a
1349 -- part of the freeze node.
1352 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1355 Analyze_List
(Actions
);
1357 -- When the type the finalization master is being generated for was
1358 -- created to store a 'Old object, then mark it as such so its
1359 -- finalization can be delayed until after postconditions have been
1362 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1363 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1366 end Build_Finalization_Master
;
1368 ---------------------
1369 -- Build_Finalizer --
1370 ---------------------
1372 procedure Build_Finalizer
1374 Clean_Stmts
: List_Id
;
1375 Mark_Id
: Entity_Id
;
1376 Top_Decls
: List_Id
;
1377 Defer_Abort
: Boolean;
1378 Fin_Id
: out Entity_Id
)
1380 Acts_As_Clean
: constant Boolean :=
1383 (Present
(Clean_Stmts
)
1384 and then Is_Non_Empty_List
(Clean_Stmts
));
1386 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1387 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1388 For_Package
: constant Boolean :=
1389 For_Package_Body
or else For_Package_Spec
;
1390 Loc
: constant Source_Ptr
:= Sloc
(N
);
1392 -- NOTE: Local variable declarations are conservative and do not create
1393 -- structures right from the start. Entities and lists are created once
1394 -- it has been established that N has at least one controlled object.
1396 Components_Built
: Boolean := False;
1397 -- A flag used to avoid double initialization of entities and lists. If
1398 -- the flag is set then the following variables have been initialized:
1404 Counter_Id
: Entity_Id
:= Empty
;
1405 Counter_Val
: Nat
:= 0;
1406 -- Name and value of the state counter
1408 Decls
: List_Id
:= No_List
;
1409 -- Declarative region of N (if available). If N is a package declaration
1410 -- Decls denotes the visible declarations.
1412 Finalizer_Data
: Finalization_Exception_Data
;
1413 -- Data for the exception
1415 Finalizer_Decls
: List_Id
:= No_List
;
1416 -- Local variable declarations. This list holds the label declarations
1417 -- of all jump block alternatives as well as the declaration of the
1418 -- local exception occurrence and the raised flag:
1419 -- E : Exception_Occurrence;
1420 -- Raised : Boolean := False;
1421 -- L<counter value> : label;
1423 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1424 -- Insertion point for the finalizer body. Depending on the context
1425 -- (Nkind of N) and the individual grouping of controlled objects, this
1426 -- node may denote a package declaration or body, package instantiation,
1427 -- block statement or a counter update statement.
1429 Finalizer_Stmts
: List_Id
:= No_List
;
1430 -- The statement list of the finalizer body. It contains the following:
1432 -- Abort_Defer; -- Added if abort is allowed
1433 -- <call to Prev_At_End> -- Added if exists
1434 -- <cleanup statements> -- Added if Acts_As_Clean
1435 -- <jump block> -- Added if Has_Ctrl_Objs
1436 -- <finalization statements> -- Added if Has_Ctrl_Objs
1437 -- <stack release> -- Added if Mark_Id exists
1438 -- Abort_Undefer; -- Added if abort is allowed
1440 Has_Ctrl_Objs
: Boolean := False;
1441 -- A general flag which denotes whether N has at least one controlled
1444 Has_Tagged_Types
: Boolean := False;
1445 -- A general flag which indicates whether N has at least one library-
1446 -- level tagged type declaration.
1448 HSS
: Node_Id
:= Empty
;
1449 -- The sequence of statements of N (if available)
1451 Jump_Alts
: List_Id
:= No_List
;
1452 -- Jump block alternatives. Depending on the value of the state counter,
1453 -- the control flow jumps to a sequence of finalization statements. This
1454 -- list contains the following:
1456 -- when <counter value> =>
1457 -- goto L<counter value>;
1459 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1460 -- Specific point in the finalizer statements where the jump block is
1463 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1464 -- The last controlled construct encountered when processing the top
1465 -- level lists of N. This can be a nested package, an instantiation or
1466 -- an object declaration.
1468 Prev_At_End
: Entity_Id
:= Empty
;
1469 -- The previous at end procedure of the handled statements block of N
1471 Priv_Decls
: List_Id
:= No_List
;
1472 -- The private declarations of N if N is a package declaration
1474 Spec_Id
: Entity_Id
:= Empty
;
1475 Spec_Decls
: List_Id
:= Top_Decls
;
1476 Stmts
: List_Id
:= No_List
;
1478 Tagged_Type_Stmts
: List_Id
:= No_List
;
1479 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1480 -- tagged types found in N.
1482 -----------------------
1483 -- Local subprograms --
1484 -----------------------
1486 procedure Build_Components
;
1487 -- Create all entites and initialize all lists used in the creation of
1490 procedure Create_Finalizer
;
1491 -- Create the spec and body of the finalizer and insert them in the
1492 -- proper place in the tree depending on the context.
1494 function New_Finalizer_Name
1495 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1496 -- Create a fully qualified name of a package spec or body finalizer.
1497 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1499 procedure Process_Declarations
1501 Preprocess
: Boolean := False;
1502 Top_Level
: Boolean := False);
1503 -- Inspect a list of declarations or statements which may contain
1504 -- objects that need finalization. When flag Preprocess is set, the
1505 -- routine will simply count the total number of controlled objects in
1506 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1507 -- when Preprocess is set and if True, the processing is performed for
1508 -- objects in nested package declarations or instances.
1510 procedure Process_Object_Declaration
1512 Has_No_Init
: Boolean := False;
1513 Is_Protected
: Boolean := False);
1514 -- Generate all the machinery associated with the finalization of a
1515 -- single object. Flag Has_No_Init is used to denote certain contexts
1516 -- where Decl does not have initialization call(s). Flag Is_Protected
1517 -- is set when Decl denotes a simple protected object.
1519 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1520 -- Generate all the code necessary to unregister the external tag of a
1523 ----------------------
1524 -- Build_Components --
1525 ----------------------
1527 procedure Build_Components
is
1528 Counter_Decl
: Node_Id
;
1529 Counter_Typ
: Entity_Id
;
1530 Counter_Typ_Decl
: Node_Id
;
1533 pragma Assert
(Present
(Decls
));
1535 -- This routine might be invoked several times when dealing with
1536 -- constructs that have two lists (either two declarative regions
1537 -- or declarations and statements). Avoid double initialization.
1539 if Components_Built
then
1543 Components_Built
:= True;
1545 if Has_Ctrl_Objs
then
1547 -- Create entities for the counter, its type, the local exception
1548 -- and the raised flag.
1550 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1551 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1553 Finalizer_Decls
:= New_List
;
1555 Build_Object_Declarations
1556 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1558 -- Since the total number of controlled objects is always known,
1559 -- build a subtype of Natural with precise bounds. This allows
1560 -- the backend to optimize the case statement. Generate:
1562 -- subtype Tnn is Natural range 0 .. Counter_Val;
1565 Make_Subtype_Declaration
(Loc
,
1566 Defining_Identifier
=> Counter_Typ
,
1567 Subtype_Indication
=>
1568 Make_Subtype_Indication
(Loc
,
1569 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1571 Make_Range_Constraint
(Loc
,
1575 Make_Integer_Literal
(Loc
, Uint_0
),
1577 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1579 -- Generate the declaration of the counter itself:
1581 -- Counter : Integer := 0;
1584 Make_Object_Declaration
(Loc
,
1585 Defining_Identifier
=> Counter_Id
,
1586 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1587 Expression
=> Make_Integer_Literal
(Loc
, 0));
1589 -- Set the type of the counter explicitly to prevent errors when
1590 -- examining object declarations later on.
1592 Set_Etype
(Counter_Id
, Counter_Typ
);
1594 if Debug_Generated_Code
then
1595 Set_Debug_Info_Needed
(Counter_Id
);
1598 -- The counter and its type are inserted before the source
1599 -- declarations of N.
1601 Prepend_To
(Decls
, Counter_Decl
);
1602 Prepend_To
(Decls
, Counter_Typ_Decl
);
1604 -- The counter and its associated type must be manually analyzed
1605 -- since N has already been analyzed. Use the scope of the spec
1606 -- when inserting in a package.
1609 Push_Scope
(Spec_Id
);
1610 Analyze
(Counter_Typ_Decl
);
1611 Analyze
(Counter_Decl
);
1615 Analyze
(Counter_Typ_Decl
);
1616 Analyze
(Counter_Decl
);
1619 Jump_Alts
:= New_List
;
1622 -- If the context requires additional cleanup, the finalization
1623 -- machinery is added after the cleanup code.
1625 if Acts_As_Clean
then
1626 Finalizer_Stmts
:= Clean_Stmts
;
1627 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1629 Finalizer_Stmts
:= New_List
;
1632 if Has_Tagged_Types
then
1633 Tagged_Type_Stmts
:= New_List
;
1635 end Build_Components
;
1637 ----------------------
1638 -- Create_Finalizer --
1639 ----------------------
1641 procedure Create_Finalizer
is
1642 Body_Id
: Entity_Id
;
1645 Jump_Block
: Node_Id
;
1647 Label_Id
: Entity_Id
;
1650 -- Step 1: Creation of the finalizer name
1652 -- Packages must use a distinct name for their finalizers since the
1653 -- binder will have to generate calls to them by name. The name is
1654 -- of the following form:
1656 -- xx__yy__finalize_[spec|body]
1659 Fin_Id
:= Make_Defining_Identifier
1660 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1661 Set_Has_Qualified_Name
(Fin_Id
);
1662 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1664 -- The default name is _finalizer
1667 -- Generation of a finalization procedure exclusively for 'Old
1668 -- interally generated constants requires different name since
1669 -- there will need to be multiple finalization routines in the
1670 -- same scope. See Build_Finalizer for details.
1673 Make_Defining_Identifier
(Loc
,
1674 Chars
=> New_External_Name
(Name_uFinalizer
));
1676 -- The visibility semantics of AT_END handlers force a strange
1677 -- separation of spec and body for stack-related finalizers:
1679 -- declare : Enclosing_Scope
1680 -- procedure _finalizer;
1682 -- <controlled objects>
1683 -- procedure _finalizer is
1689 -- Both spec and body are within the same construct and scope, but
1690 -- the body is part of the handled sequence of statements. This
1691 -- placement confuses the elaboration mechanism on targets where
1692 -- AT_END handlers are expanded into "when all others" handlers:
1695 -- when all others =>
1696 -- _finalizer; -- appears to require elab checks
1701 -- Since the compiler guarantees that the body of a _finalizer is
1702 -- always inserted in the same construct where the AT_END handler
1703 -- resides, there is no need for elaboration checks.
1705 Set_Kill_Elaboration_Checks
(Fin_Id
);
1707 -- Inlining the finalizer produces a substantial speedup at -O2.
1708 -- It is inlined by default at -O3. Either way, it is called
1709 -- exactly twice (once on the normal path, and once for
1710 -- exceptions/abort), so this won't bloat the code too much.
1712 Set_Is_Inlined
(Fin_Id
);
1715 if Debug_Generated_Code
then
1716 Set_Debug_Info_Needed
(Fin_Id
);
1719 -- Step 2: Creation of the finalizer specification
1722 -- procedure Fin_Id;
1725 Make_Subprogram_Declaration
(Loc
,
1727 Make_Procedure_Specification
(Loc
,
1728 Defining_Unit_Name
=> Fin_Id
));
1731 Set_Is_Exported
(Fin_Id
);
1732 Set_Interface_Name
(Fin_Id
,
1733 Make_String_Literal
(Loc
,
1734 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1737 -- Step 3: Creation of the finalizer body
1739 -- Has_Ctrl_Objs might be set because of a generic package body having
1740 -- controlled objects. In this case, Jump_Alts may be empty and no
1741 -- case nor goto statements are needed.
1744 and then not Is_Empty_List
(Jump_Alts
)
1746 -- Add L0, the default destination to the jump block
1748 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1749 Set_Entity
(Label_Id
,
1750 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1751 Label
:= Make_Label
(Loc
, Label_Id
);
1756 Prepend_To
(Finalizer_Decls
,
1757 Make_Implicit_Label_Declaration
(Loc
,
1758 Defining_Identifier
=> Entity
(Label_Id
),
1759 Label_Construct
=> Label
));
1765 Append_To
(Jump_Alts
,
1766 Make_Case_Statement_Alternative
(Loc
,
1767 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1768 Statements
=> New_List
(
1769 Make_Goto_Statement
(Loc
,
1770 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1775 Append_To
(Finalizer_Stmts
, Label
);
1777 -- Create the jump block which controls the finalization flow
1778 -- depending on the value of the state counter.
1781 Make_Case_Statement
(Loc
,
1782 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1783 Alternatives
=> Jump_Alts
);
1785 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1786 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1788 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1792 -- Add the library-level tagged type unregistration machinery before
1793 -- the jump block circuitry. This ensures that external tags will be
1794 -- removed even if a finalization exception occurs at some point.
1796 if Has_Tagged_Types
then
1797 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1800 -- Add a call to the previous At_End handler if it exists. The call
1801 -- must always precede the jump block.
1803 if Present
(Prev_At_End
) then
1804 Prepend_To
(Finalizer_Stmts
,
1805 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1807 -- Clear the At_End handler since we have already generated the
1808 -- proper replacement call for it.
1810 Set_At_End_Proc
(HSS
, Empty
);
1813 -- Release the secondary stack
1815 if Present
(Mark_Id
) then
1817 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1820 -- If the context is a build-in-place function, the secondary
1821 -- stack must be released, unless the build-in-place function
1822 -- itself is returning on the secondary stack. Generate:
1824 -- if BIP_Alloc_Form /= Secondary_Stack then
1825 -- SS_Release (Mark_Id);
1828 -- Note that if the function returns on the secondary stack,
1829 -- then the responsibility of reclaiming the space is always
1830 -- left to the caller (recursively if needed).
1832 if Nkind
(N
) = N_Subprogram_Body
then
1834 Spec_Id
: constant Entity_Id
:=
1835 Unique_Defining_Entity
(N
);
1836 BIP_SS
: constant Boolean :=
1837 Is_Build_In_Place_Function
(Spec_Id
)
1838 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1842 Make_If_Statement
(Loc
,
1847 (Build_In_Place_Formal
1848 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1850 Make_Integer_Literal
(Loc
,
1852 (BIP_Allocation_Form
'Pos
1853 (Secondary_Stack
)))),
1855 Then_Statements
=> New_List
(Release
));
1860 Append_To
(Finalizer_Stmts
, Release
);
1864 -- Protect the statements with abort defer/undefer. This is only when
1865 -- aborts are allowed and the cleanup statements require deferral or
1866 -- there are controlled objects to be finalized. Note that the abort
1867 -- defer/undefer pair does not require an extra block because each
1868 -- finalization exception is caught in its corresponding finalization
1869 -- block. As a result, the call to Abort_Defer always takes place.
1871 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1872 Prepend_To
(Finalizer_Stmts
,
1873 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1875 Append_To
(Finalizer_Stmts
,
1876 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1879 -- The local exception does not need to be reraised for library-level
1880 -- finalizers. Note that this action must be carried out after object
1881 -- cleanup, secondary stack release, and abort undeferral. Generate:
1883 -- if Raised and then not Abort then
1884 -- Raise_From_Controlled_Operation (E);
1887 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1888 Append_To
(Finalizer_Stmts
,
1889 Build_Raise_Statement
(Finalizer_Data
));
1893 -- procedure Fin_Id is
1894 -- Abort : constant Boolean := Triggered_By_Abort;
1896 -- Abort : constant Boolean := False; -- no abort
1898 -- E : Exception_Occurrence; -- All added if flag
1899 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1905 -- Abort_Defer; -- Added if abort is allowed
1906 -- <call to Prev_At_End> -- Added if exists
1907 -- <cleanup statements> -- Added if Acts_As_Clean
1908 -- <jump block> -- Added if Has_Ctrl_Objs
1909 -- <finalization statements> -- Added if Has_Ctrl_Objs
1910 -- <stack release> -- Added if Mark_Id exists
1911 -- Abort_Undefer; -- Added if abort is allowed
1912 -- <exception propagation> -- Added if Has_Ctrl_Objs
1915 -- Create the body of the finalizer
1917 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1919 if Debug_Generated_Code
then
1920 Set_Debug_Info_Needed
(Body_Id
);
1924 Set_Has_Qualified_Name
(Body_Id
);
1925 Set_Has_Fully_Qualified_Name
(Body_Id
);
1929 Make_Subprogram_Body
(Loc
,
1931 Make_Procedure_Specification
(Loc
,
1932 Defining_Unit_Name
=> Body_Id
),
1933 Declarations
=> Finalizer_Decls
,
1934 Handled_Statement_Sequence
=>
1935 Make_Handled_Sequence_Of_Statements
(Loc
,
1936 Statements
=> Finalizer_Stmts
));
1938 -- Step 4: Spec and body insertion, analysis
1942 -- If the package spec has private declarations, the finalizer
1943 -- body must be added to the end of the list in order to have
1944 -- visibility of all private controlled objects.
1946 if For_Package_Spec
then
1947 if Present
(Priv_Decls
) then
1948 Append_To
(Priv_Decls
, Fin_Spec
);
1949 Append_To
(Priv_Decls
, Fin_Body
);
1951 Append_To
(Decls
, Fin_Spec
);
1952 Append_To
(Decls
, Fin_Body
);
1955 -- For package bodies, both the finalizer spec and body are
1956 -- inserted at the end of the package declarations.
1959 Append_To
(Decls
, Fin_Spec
);
1960 Append_To
(Decls
, Fin_Body
);
1963 -- Push the name of the package
1965 Push_Scope
(Spec_Id
);
1973 -- Create the spec for the finalizer. The At_End handler must be
1974 -- able to call the body which resides in a nested structure.
1978 -- procedure Fin_Id; -- Spec
1980 -- <objects and possibly statements>
1981 -- procedure Fin_Id is ... -- Body
1984 -- Fin_Id; -- At_End handler
1987 pragma Assert
(Present
(Spec_Decls
));
1989 -- It maybe possible that we are finalizing 'Old objects which
1990 -- exist in the spec declarations. When this is the case the
1991 -- Finalizer_Insert_Node will come before the end of the
1992 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1993 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1994 -- end of Spec_Decls to prevent its body appearing before its
1995 -- corresponding spec.
1997 if Present
(Finalizer_Insert_Nod
)
1998 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
2000 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
2001 Finalizer_Insert_Nod
:= Fin_Spec
;
2003 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
2006 Append_To
(Spec_Decls
, Fin_Spec
);
2010 -- When the finalizer acts solely as a cleanup routine, the body
2011 -- is inserted right after the spec.
2013 if Acts_As_Clean
and not Has_Ctrl_Objs
then
2014 Insert_After
(Fin_Spec
, Fin_Body
);
2016 -- In all other cases the body is inserted after either:
2018 -- 1) The counter update statement of the last controlled object
2019 -- 2) The last top level nested controlled package
2020 -- 3) The last top level controlled instantiation
2023 -- Manually freeze the spec. This is somewhat of a hack because
2024 -- a subprogram is frozen when its body is seen and the freeze
2025 -- node appears right before the body. However, in this case,
2026 -- the spec must be frozen earlier since the At_End handler
2027 -- must be able to call it.
2030 -- procedure Fin_Id; -- Spec
2031 -- [Fin_Id] -- Freeze node
2035 -- Fin_Id; -- At_End handler
2038 Ensure_Freeze_Node
(Fin_Id
);
2039 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2040 Set_Is_Frozen
(Fin_Id
);
2042 -- In the case where the last construct to contain a controlled
2043 -- object is either a nested package, an instantiation or a
2044 -- freeze node, the body must be inserted directly after the
2045 -- construct, except if the insertion point is already placed
2046 -- after the construct, typically in the statement list.
2048 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2049 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2051 (List_Containing
(Last_Top_Level_Ctrl_Construct
) = Spec_Decls
2052 and then Present
(Stmts
)
2053 and then List_Containing
(Finalizer_Insert_Nod
) = Stmts
)
2055 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2058 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2061 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2064 -- Never consider that the finalizer procedure is enabled Ghost, even
2065 -- when the corresponding unit is Ghost, as this would lead to an
2066 -- an external name with a ___ghost_ prefix that the binder cannot
2067 -- generate, as it has no knowledge of the Ghost status of units.
2069 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2070 end Create_Finalizer
;
2072 ------------------------
2073 -- New_Finalizer_Name --
2074 ------------------------
2076 function New_Finalizer_Name
2077 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2079 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2080 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2081 -- has a non-standard scope, process the scope first.
2083 ------------------------
2084 -- New_Finalizer_Name --
2085 ------------------------
2087 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2089 if Scope
(Id
) = Standard_Standard
then
2090 Get_Name_String
(Chars
(Id
));
2093 New_Finalizer_Name
(Scope
(Id
));
2094 Add_Str_To_Name_Buffer
("__");
2095 Get_Name_String_And_Append
(Chars
(Id
));
2097 end New_Finalizer_Name
;
2099 -- Start of processing for New_Finalizer_Name
2102 -- Create the fully qualified name of the enclosing scope
2104 New_Finalizer_Name
(Spec_Id
);
2107 -- __finalize_[spec|body]
2109 Add_Str_To_Name_Buffer
("__finalize_");
2112 Add_Str_To_Name_Buffer
("spec");
2114 Add_Str_To_Name_Buffer
("body");
2118 end New_Finalizer_Name
;
2120 --------------------------
2121 -- Process_Declarations --
2122 --------------------------
2124 procedure Process_Declarations
2126 Preprocess
: Boolean := False;
2127 Top_Level
: Boolean := False)
2132 Obj_Typ
: Entity_Id
;
2133 Pack_Id
: Entity_Id
;
2137 Old_Counter_Val
: Nat
;
2138 -- This variable is used to determine whether a nested package or
2139 -- instance contains at least one controlled object.
2141 procedure Processing_Actions
2142 (Has_No_Init
: Boolean := False;
2143 Is_Protected
: Boolean := False);
2144 -- Depending on the mode of operation of Process_Declarations, either
2145 -- increment the controlled object counter, set the controlled object
2146 -- flag and store the last top level construct or process the current
2147 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2148 -- the current declaration may not have initialization proc(s). Flag
2149 -- Is_Protected should be set when the current declaration denotes a
2150 -- simple protected object.
2152 ------------------------
2153 -- Processing_Actions --
2154 ------------------------
2156 procedure Processing_Actions
2157 (Has_No_Init
: Boolean := False;
2158 Is_Protected
: Boolean := False)
2161 -- Library-level tagged type
2163 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2165 Has_Tagged_Types
:= True;
2167 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2168 Last_Top_Level_Ctrl_Construct
:= Decl
;
2171 -- Unregister tagged type, unless No_Tagged_Type_Registration
2174 elsif not Restriction_Active
(No_Tagged_Type_Registration
) then
2175 Process_Tagged_Type_Declaration
(Decl
);
2178 -- Controlled object declaration
2182 Counter_Val
:= Counter_Val
+ 1;
2183 Has_Ctrl_Objs
:= True;
2185 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2186 Last_Top_Level_Ctrl_Construct
:= Decl
;
2190 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2193 end Processing_Actions
;
2195 -- Start of processing for Process_Declarations
2198 if Is_Empty_List
(Decls
) then
2202 -- Process all declarations in reverse order
2204 Decl
:= Last_Non_Pragma
(Decls
);
2205 while Present
(Decl
) loop
2206 -- Library-level tagged types
2208 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2209 Typ
:= Defining_Identifier
(Decl
);
2211 -- Ignored Ghost types do not need any cleanup actions because
2212 -- they will not appear in the final tree.
2214 if Is_Ignored_Ghost_Entity
(Typ
) then
2217 elsif Is_Tagged_Type
(Typ
)
2218 and then Is_Library_Level_Entity
(Typ
)
2219 and then Convention
(Typ
) = Convention_Ada
2220 and then Present
(Access_Disp_Table
(Typ
))
2221 and then not Is_Abstract_Type
(Typ
)
2222 and then not No_Run_Time_Mode
2223 and then not Restriction_Active
(No_Tagged_Type_Registration
)
2224 and then RTE_Available
(RE_Register_Tag
)
2229 -- Regular object declarations
2231 elsif Nkind
(Decl
) = N_Object_Declaration
then
2232 Obj_Id
:= Defining_Identifier
(Decl
);
2233 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2234 Expr
:= Expression
(Decl
);
2236 -- Bypass any form of processing for objects which have their
2237 -- finalization disabled. This applies only to objects at the
2240 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2243 -- Finalization of transient objects are treated separately in
2244 -- order to handle sensitive cases. These include:
2246 -- * Aggregate expansion
2247 -- * If, case, and expression with actions expansion
2248 -- * Transient scopes
2250 -- If one of those contexts has marked the transient object as
2251 -- ignored, do not generate finalization actions for it.
2253 elsif Is_Finalized_Transient
(Obj_Id
)
2254 or else Is_Ignored_Transient
(Obj_Id
)
2258 -- Ignored Ghost objects do not need any cleanup actions
2259 -- because they will not appear in the final tree.
2261 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2264 -- The object is of the form:
2265 -- Obj : [constant] Typ [:= Expr];
2267 -- Do not process the incomplete view of a deferred constant.
2268 -- Note that an object initialized by means of a BIP function
2269 -- call may appear as a deferred constant after expansion
2270 -- activities. These kinds of objects must be finalized.
2272 elsif not Is_Imported
(Obj_Id
)
2273 and then Needs_Finalization
(Obj_Typ
)
2274 and then not (Ekind
(Obj_Id
) = E_Constant
2275 and then not Has_Completion
(Obj_Id
)
2276 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2280 -- The object is of the form:
2281 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2283 -- Obj : Access_Typ :=
2284 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2286 elsif Is_Access_Type
(Obj_Typ
)
2287 and then Needs_Finalization
2288 (Available_View
(Designated_Type
(Obj_Typ
)))
2289 and then Present
(Expr
)
2291 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2293 (Is_Non_BIP_Func_Call
(Expr
)
2294 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2296 Processing_Actions
(Has_No_Init
=> True);
2298 -- Processing for "hook" objects generated for transient
2299 -- objects declared inside an Expression_With_Actions.
2301 elsif Is_Access_Type
(Obj_Typ
)
2302 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2303 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2304 N_Object_Declaration
2306 Processing_Actions
(Has_No_Init
=> True);
2308 -- Process intermediate results of an if expression with one
2309 -- of the alternatives using a controlled function call.
2311 elsif Is_Access_Type
(Obj_Typ
)
2312 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2313 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2314 N_Defining_Identifier
2315 and then Present
(Expr
)
2316 and then Nkind
(Expr
) = N_Null
2318 Processing_Actions
(Has_No_Init
=> True);
2320 -- Simple protected objects which use type System.Tasking.
2321 -- Protected_Objects.Protection to manage their locks should
2322 -- be treated as controlled since they require manual cleanup.
2323 -- The only exception is illustrated in the following example:
2326 -- type Ctrl is new Controlled ...
2327 -- procedure Finalize (Obj : in out Ctrl);
2331 -- package body Pkg is
2332 -- protected Prot is
2333 -- procedure Do_Something (Obj : in out Ctrl);
2336 -- protected body Prot is
2337 -- procedure Do_Something (Obj : in out Ctrl) is ...
2340 -- procedure Finalize (Obj : in out Ctrl) is
2342 -- Prot.Do_Something (Obj);
2346 -- Since for the most part entities in package bodies depend on
2347 -- those in package specs, Prot's lock should be cleaned up
2348 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2349 -- This act however attempts to invoke Do_Something and fails
2350 -- because the lock has disappeared.
2352 elsif Ekind
(Obj_Id
) = E_Variable
2353 and then not In_Library_Level_Package_Body
(Obj_Id
)
2354 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2355 or else Has_Simple_Protected_Object
(Obj_Typ
))
2357 Processing_Actions
(Is_Protected
=> True);
2360 -- Specific cases of object renamings
2362 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2363 Obj_Id
:= Defining_Identifier
(Decl
);
2364 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2366 -- Bypass any form of processing for objects which have their
2367 -- finalization disabled. This applies only to objects at the
2370 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2373 -- Ignored Ghost object renamings do not need any cleanup
2374 -- actions because they will not appear in the final tree.
2376 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2379 -- Return object of a build-in-place function. This case is
2380 -- recognized and marked by the expansion of an extended return
2381 -- statement (see Expand_N_Extended_Return_Statement).
2383 elsif Needs_Finalization
(Obj_Typ
)
2384 and then Is_Return_Object
(Obj_Id
)
2385 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2387 Processing_Actions
(Has_No_Init
=> True);
2390 -- Inspect the freeze node of an access-to-controlled type and
2391 -- look for a delayed finalization master. This case arises when
2392 -- the freeze actions are inserted at a later time than the
2393 -- expansion of the context. Since Build_Finalizer is never called
2394 -- on a single construct twice, the master will be ultimately
2395 -- left out and never finalized. This is also needed for freeze
2396 -- actions of designated types themselves, since in some cases the
2397 -- finalization master is associated with a designated type's
2398 -- freeze node rather than that of the access type (see handling
2399 -- for freeze actions in Build_Finalization_Master).
2401 elsif Nkind
(Decl
) = N_Freeze_Entity
2402 and then Present
(Actions
(Decl
))
2404 Typ
:= Entity
(Decl
);
2406 -- Freeze nodes for ignored Ghost types do not need cleanup
2407 -- actions because they will never appear in the final tree.
2409 if Is_Ignored_Ghost_Entity
(Typ
) then
2412 elsif (Is_Access_Object_Type
(Typ
)
2413 and then Needs_Finalization
2414 (Available_View
(Designated_Type
(Typ
))))
2415 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2417 Old_Counter_Val
:= Counter_Val
;
2419 -- Freeze nodes are considered to be identical to packages
2420 -- and blocks in terms of nesting. The difference is that
2421 -- a finalization master created inside the freeze node is
2422 -- at the same nesting level as the node itself.
2424 Process_Declarations
(Actions
(Decl
), Preprocess
);
2426 -- The freeze node contains a finalization master
2430 and then No
(Last_Top_Level_Ctrl_Construct
)
2431 and then Counter_Val
> Old_Counter_Val
2433 Last_Top_Level_Ctrl_Construct
:= Decl
;
2437 -- Nested package declarations, avoid generics
2439 elsif Nkind
(Decl
) = N_Package_Declaration
then
2440 Pack_Id
:= Defining_Entity
(Decl
);
2441 Spec
:= Specification
(Decl
);
2443 -- Do not inspect an ignored Ghost package because all code
2444 -- found within will not appear in the final tree.
2446 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2449 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2450 Old_Counter_Val
:= Counter_Val
;
2451 Process_Declarations
2452 (Private_Declarations
(Spec
), Preprocess
);
2453 Process_Declarations
2454 (Visible_Declarations
(Spec
), Preprocess
);
2456 -- Either the visible or the private declarations contain a
2457 -- controlled object. The nested package declaration is the
2458 -- last such construct.
2462 and then No
(Last_Top_Level_Ctrl_Construct
)
2463 and then Counter_Val
> Old_Counter_Val
2465 Last_Top_Level_Ctrl_Construct
:= Decl
;
2469 -- Call the xxx__finalize_body procedure of a library level
2470 -- package instantiation if the body contains finalization
2473 if Present
(Generic_Parent
(Spec
))
2474 and then Is_Library_Level_Entity
(Pack_Id
)
2475 and then Present
(Body_Entity
(Generic_Parent
(Spec
)))
2481 P
:= Parent
(Body_Entity
(Generic_Parent
(Spec
)));
2483 and then Nkind
(P
) /= N_Package_Body
2489 Old_Counter_Val
:= Counter_Val
;
2490 Process_Declarations
(Declarations
(P
), Preprocess
);
2492 -- Note that we are processing the generic body
2493 -- template and not the actually instantiation
2494 -- (which is generated too late for us to process
2495 -- it), so there is no need to update in particular
2496 -- Last_Top_Level_Ctrl_Construct here.
2498 if Counter_Val
> Old_Counter_Val
then
2499 Counter_Val
:= Old_Counter_Val
;
2500 Set_Has_Controlled_Component
(Pack_Id
);
2505 elsif Has_Controlled_Component
(Pack_Id
) then
2507 -- We import the xxx__finalize_body routine since the
2508 -- generic body will be instantiated later.
2511 Id
: constant Node_Id
:=
2512 Make_Defining_Identifier
(Loc
,
2513 New_Finalizer_Name
(Defining_Unit_Name
(Spec
),
2514 For_Spec
=> False));
2517 Set_Has_Qualified_Name
(Id
);
2518 Set_Has_Fully_Qualified_Name
(Id
);
2519 Set_Is_Imported
(Id
);
2520 Set_Has_Completion
(Id
);
2521 Set_Interface_Name
(Id
,
2522 Make_String_Literal
(Loc
,
2523 Strval
=> Get_Name_String
(Chars
(Id
))));
2525 Append_New_To
(Finalizer_Stmts
,
2526 Make_Subprogram_Declaration
(Loc
,
2527 Make_Procedure_Specification
(Loc
,
2528 Defining_Unit_Name
=> Id
)));
2529 Append_To
(Finalizer_Stmts
,
2530 Make_Procedure_Call_Statement
(Loc
,
2531 Name
=> New_Occurrence_Of
(Id
, Loc
)));
2536 -- Nested package bodies, avoid generics
2538 elsif Nkind
(Decl
) = N_Package_Body
then
2540 -- Do not inspect an ignored Ghost package body because all
2541 -- code found within will not appear in the final tree.
2543 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2546 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
2548 Old_Counter_Val
:= Counter_Val
;
2549 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2551 -- The nested package body is the last construct to contain
2552 -- a controlled object.
2556 and then No
(Last_Top_Level_Ctrl_Construct
)
2557 and then Counter_Val
> Old_Counter_Val
2559 Last_Top_Level_Ctrl_Construct
:= Decl
;
2563 -- Handle a rare case caused by a controlled transient object
2564 -- created as part of a record init proc. The variable is wrapped
2565 -- in a block, but the block is not associated with a transient
2568 elsif Nkind
(Decl
) = N_Block_Statement
2569 and then Inside_Init_Proc
2571 Old_Counter_Val
:= Counter_Val
;
2573 if Present
(Handled_Statement_Sequence
(Decl
)) then
2574 Process_Declarations
2575 (Statements
(Handled_Statement_Sequence
(Decl
)),
2579 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2581 -- Either the declaration or statement list of the block has a
2582 -- controlled object.
2586 and then No
(Last_Top_Level_Ctrl_Construct
)
2587 and then Counter_Val
> Old_Counter_Val
2589 Last_Top_Level_Ctrl_Construct
:= Decl
;
2592 -- Handle the case where the original context has been wrapped in
2593 -- a block to avoid interference between exception handlers and
2594 -- At_End handlers. Treat the block as transparent and process its
2597 elsif Nkind
(Decl
) = N_Block_Statement
2598 and then Is_Finalization_Wrapper
(Decl
)
2600 if Present
(Handled_Statement_Sequence
(Decl
)) then
2601 Process_Declarations
2602 (Statements
(Handled_Statement_Sequence
(Decl
)),
2606 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2609 Prev_Non_Pragma
(Decl
);
2611 end Process_Declarations
;
2613 --------------------------------
2614 -- Process_Object_Declaration --
2615 --------------------------------
2617 procedure Process_Object_Declaration
2619 Has_No_Init
: Boolean := False;
2620 Is_Protected
: Boolean := False)
2622 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2623 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2625 Init_Typ
: Entity_Id
;
2626 -- The initialization type of the related object declaration. Note
2627 -- that this is not necessarily the same type as Obj_Typ because of
2628 -- possible type derivations.
2630 Obj_Typ
: Entity_Id
;
2631 -- The type of the related object declaration
2633 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2634 -- Func_Id denotes a build-in-place function. Generate the following
2637 -- if BIPallocfrom > Secondary_Stack'Pos
2638 -- and then BIPfinalizationmaster /= null
2641 -- type Ptr_Typ is access Obj_Typ;
2642 -- for Ptr_Typ'Storage_Pool
2643 -- use Base_Pool (BIPfinalizationmaster);
2645 -- Free (Ptr_Typ (Temp));
2649 -- Obj_Typ is the type of the current object, Temp is the original
2650 -- allocation which Obj_Id renames.
2652 procedure Find_Last_Init
2653 (Last_Init
: out Node_Id
;
2654 Body_Insert
: out Node_Id
);
2655 -- Find the last initialization call related to object declaration
2656 -- Decl. Last_Init denotes the last initialization call which follows
2657 -- Decl. Body_Insert denotes a node where the finalizer body could be
2658 -- potentially inserted after (if blocks are involved).
2660 -----------------------------
2661 -- Build_BIP_Cleanup_Stmts --
2662 -----------------------------
2664 function Build_BIP_Cleanup_Stmts
2665 (Func_Id
: Entity_Id
) return Node_Id
2667 Decls
: constant List_Id
:= New_List
;
2668 Fin_Mas_Id
: constant Entity_Id
:=
2669 Build_In_Place_Formal
2670 (Func_Id
, BIP_Finalization_Master
);
2671 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2672 Temp_Id
: constant Entity_Id
:=
2673 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2677 Free_Stmt
: Node_Id
;
2678 Pool_Id
: Entity_Id
;
2679 Ptr_Typ
: Entity_Id
;
2683 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2685 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2688 Make_Object_Renaming_Declaration
(Loc
,
2689 Defining_Identifier
=> Pool_Id
,
2691 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2693 Make_Explicit_Dereference
(Loc
,
2695 Make_Function_Call
(Loc
,
2697 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2698 Parameter_Associations
=> New_List
(
2699 Make_Explicit_Dereference
(Loc
,
2701 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2703 -- Create an access type which uses the storage pool of the
2704 -- caller's finalization master.
2707 -- type Ptr_Typ is access Func_Typ;
2709 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2712 Make_Full_Type_Declaration
(Loc
,
2713 Defining_Identifier
=> Ptr_Typ
,
2715 Make_Access_To_Object_Definition
(Loc
,
2716 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2718 -- Perform minor decoration in order to set the master and the
2719 -- storage pool attributes.
2721 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2722 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2723 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2725 if Debug_Generated_Code
then
2726 Set_Debug_Info_Needed
(Pool_Id
);
2729 -- Create an explicit free statement. Note that the free uses the
2730 -- caller's pool expressed as a renaming.
2733 Make_Free_Statement
(Loc
,
2735 Unchecked_Convert_To
(Ptr_Typ
,
2736 New_Occurrence_Of
(Temp_Id
, Loc
)));
2738 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2740 -- Create a block to house the dummy type and the instantiation as
2741 -- well as to perform the cleanup the temporary.
2747 -- Free (Ptr_Typ (Temp_Id));
2751 Make_Block_Statement
(Loc
,
2752 Declarations
=> Decls
,
2753 Handled_Statement_Sequence
=>
2754 Make_Handled_Sequence_Of_Statements
(Loc
,
2755 Statements
=> New_List
(Free_Stmt
)));
2758 -- if BIPfinalizationmaster /= null then
2762 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2763 Right_Opnd
=> Make_Null
(Loc
));
2765 -- For unconstrained or tagged results, escalate the condition to
2766 -- include the allocation format. Generate:
2768 -- if BIPallocform > Secondary_Stack'Pos
2769 -- and then BIPfinalizationmaster /= null
2772 if Needs_BIP_Alloc_Form
(Func_Id
) then
2774 Alloc
: constant Entity_Id
:=
2775 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2781 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2783 Make_Integer_Literal
(Loc
,
2785 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2787 Right_Opnd
=> Cond
);
2797 Make_If_Statement
(Loc
,
2799 Then_Statements
=> New_List
(Free_Blk
));
2800 end Build_BIP_Cleanup_Stmts
;
2802 --------------------
2803 -- Find_Last_Init --
2804 --------------------
2806 procedure Find_Last_Init
2807 (Last_Init
: out Node_Id
;
2808 Body_Insert
: out Node_Id
)
2810 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2811 -- Find the last initialization call within the statements of
2814 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2815 -- Determine whether node N denotes one of the initialization
2816 -- procedures of types Init_Typ or Obj_Typ.
2818 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2819 -- Obtain the next statement which follows list member Stmt while
2820 -- ignoring artifacts related to access-before-elaboration checks.
2822 -----------------------------
2823 -- Find_Last_Init_In_Block --
2824 -----------------------------
2826 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2827 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2831 -- Examine the individual statements of the block in reverse to
2832 -- locate the last initialization call.
2834 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2835 Stmt
:= Last
(Statements
(HSS
));
2836 while Present
(Stmt
) loop
2838 -- Peek inside nested blocks in case aborts are allowed
2840 if Nkind
(Stmt
) = N_Block_Statement
then
2841 return Find_Last_Init_In_Block
(Stmt
);
2843 elsif Is_Init_Call
(Stmt
) then
2852 end Find_Last_Init_In_Block
;
2858 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2859 function Is_Init_Proc_Of
2860 (Subp_Id
: Entity_Id
;
2861 Typ
: Entity_Id
) return Boolean;
2862 -- Determine whether subprogram Subp_Id is a valid init proc of
2865 ---------------------
2866 -- Is_Init_Proc_Of --
2867 ---------------------
2869 function Is_Init_Proc_Of
2870 (Subp_Id
: Entity_Id
;
2871 Typ
: Entity_Id
) return Boolean
2873 Deep_Init
: Entity_Id
:= Empty
;
2874 Prim_Init
: Entity_Id
:= Empty
;
2875 Type_Init
: Entity_Id
:= Empty
;
2878 -- Obtain all possible initialization routines of the
2879 -- related type and try to match the subprogram entity
2880 -- against one of them.
2884 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2886 -- Primitive Initialize
2888 if Is_Controlled
(Typ
) then
2889 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2891 if Present
(Prim_Init
) then
2892 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2896 -- Type initialization routine
2898 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2899 Type_Init
:= Base_Init_Proc
(Typ
);
2903 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2905 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2907 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2908 end Is_Init_Proc_Of
;
2912 Call_Id
: Entity_Id
;
2914 -- Start of processing for Is_Init_Call
2917 if Nkind
(N
) = N_Procedure_Call_Statement
2918 and then Nkind
(Name
(N
)) = N_Identifier
2920 Call_Id
:= Entity
(Name
(N
));
2922 -- Consider both the type of the object declaration and its
2923 -- related initialization type.
2926 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2928 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2934 -----------------------------
2935 -- Next_Suitable_Statement --
2936 -----------------------------
2938 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2942 -- Skip call markers and Program_Error raises installed by the
2945 Result
:= Next
(Stmt
);
2946 while Present
(Result
) loop
2947 exit when Nkind
(Result
) not in
2948 N_Call_Marker | N_Raise_Program_Error
;
2954 end Next_Suitable_Statement
;
2962 Deep_Init_Found
: Boolean := False;
2963 -- A flag set when a call to [Deep_]Initialize has been found
2965 -- Start of processing for Find_Last_Init
2969 Body_Insert
:= Empty
;
2971 -- Object renamings and objects associated with controlled
2972 -- function results do not require initialization.
2978 Stmt
:= Next_Suitable_Statement
(Decl
);
2980 -- For an object with suppressed initialization, we check whether
2981 -- there is in fact no initialization expression. If there is not,
2982 -- then this is an object declaration that has been turned into a
2983 -- different object declaration that calls the build-in-place
2984 -- function in a 'Reference attribute, as in "F(...)'Reference".
2985 -- We search for that later object declaration, so that the
2986 -- Inc_Decl will be inserted after the call. Otherwise, if the
2987 -- call raises an exception, we will finalize the (uninitialized)
2988 -- object, which is wrong.
2990 if No_Initialization
(Decl
) then
2991 if No
(Expression
(Last_Init
)) then
2994 exit when No
(Last_Init
);
2995 exit when Nkind
(Last_Init
) = N_Object_Declaration
2996 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2997 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2999 and then Is_Expanded_Build_In_Place_Call
3000 (Prefix
(Expression
(Last_Init
)));
3006 -- If the initialization is in the declaration, we're done, so
3007 -- early return if we have no more statements or they have been
3008 -- rewritten, which means that they were in the source code.
3010 elsif No
(Stmt
) or else Original_Node
(Stmt
) /= Stmt
then
3013 -- In all other cases the initialization calls follow the related
3014 -- object. The general structure of object initialization built by
3015 -- routine Default_Initialize_Object is as follows:
3017 -- [begin -- aborts allowed
3019 -- Type_Init_Proc (Obj);
3020 -- [begin] -- exceptions allowed
3021 -- Deep_Initialize (Obj);
3022 -- [exception -- exceptions allowed
3024 -- Deep_Finalize (Obj, Self => False);
3027 -- [at end -- aborts allowed
3031 -- When aborts are allowed, the initialization calls are housed
3034 elsif Nkind
(Stmt
) = N_Block_Statement
then
3035 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
3036 Body_Insert
:= Stmt
;
3038 -- Otherwise the initialization calls follow the related object
3041 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
3043 -- Check for an optional call to Deep_Initialize which may
3044 -- appear within a block depending on whether the object has
3045 -- controlled components.
3047 if Present
(Stmt_2
) then
3048 if Nkind
(Stmt_2
) = N_Block_Statement
then
3049 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
3051 if Present
(Call
) then
3052 Deep_Init_Found
:= True;
3054 Body_Insert
:= Stmt_2
;
3057 elsif Is_Init_Call
(Stmt_2
) then
3058 Deep_Init_Found
:= True;
3059 Last_Init
:= Stmt_2
;
3060 Body_Insert
:= Last_Init
;
3064 -- If the object lacks a call to Deep_Initialize, then it must
3065 -- have a call to its related type init proc.
3067 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
3069 Body_Insert
:= Last_Init
;
3077 Count_Ins
: Node_Id
;
3079 Fin_Stmts
: List_Id
:= No_List
;
3082 Label_Id
: Entity_Id
;
3085 -- Start of processing for Process_Object_Declaration
3088 -- Handle the object type and the reference to the object
3090 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
3091 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
3094 if Is_Access_Type
(Obj_Typ
) then
3095 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
3096 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
3098 elsif Is_Concurrent_Type
(Obj_Typ
)
3099 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
3101 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
3102 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3104 elsif Is_Private_Type
(Obj_Typ
)
3105 and then Present
(Full_View
(Obj_Typ
))
3107 Obj_Typ
:= Full_View
(Obj_Typ
);
3108 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3110 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3111 Obj_Typ
:= Base_Type
(Obj_Typ
);
3112 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3119 Set_Etype
(Obj_Ref
, Obj_Typ
);
3121 -- Handle the initialization type of the object declaration
3123 Init_Typ
:= Obj_Typ
;
3125 if Is_Private_Type
(Init_Typ
)
3126 and then Present
(Full_View
(Init_Typ
))
3128 Init_Typ
:= Full_View
(Init_Typ
);
3130 elsif Is_Untagged_Derivation
(Init_Typ
) then
3131 Init_Typ
:= Root_Type
(Init_Typ
);
3138 -- Set a new value for the state counter and insert the statement
3139 -- after the object declaration. Generate:
3141 -- Counter := <value>;
3144 Make_Assignment_Statement
(Loc
,
3145 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3146 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3148 -- Insert the counter after all initialization has been done. The
3149 -- place of insertion depends on the context.
3151 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3153 -- The object is initialized by a build-in-place function call.
3154 -- The counter insertion point is after the function call.
3156 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3157 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3160 -- The object is initialized by an aggregate. Insert the counter
3161 -- after the last aggregate assignment.
3163 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3164 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3167 -- In all other cases the counter is inserted after the last call
3168 -- to either [Deep_]Initialize or the type-specific init proc.
3171 Find_Last_Init
(Count_Ins
, Body_Ins
);
3174 -- In all other cases the counter is inserted after the last call to
3175 -- either [Deep_]Initialize or the type-specific init proc.
3178 Find_Last_Init
(Count_Ins
, Body_Ins
);
3181 -- If the Initialize function is null or trivial, the call will have
3182 -- been replaced with a null statement, in which case place counter
3183 -- declaration after object declaration itself.
3185 if No
(Count_Ins
) then
3189 Insert_After
(Count_Ins
, Inc_Decl
);
3192 -- If the current declaration is the last in the list, the finalizer
3193 -- body needs to be inserted after the set counter statement for the
3194 -- current object declaration. This is complicated by the fact that
3195 -- the set counter statement may appear in abort deferred block. In
3196 -- that case, the proper insertion place is after the block.
3198 if No
(Finalizer_Insert_Nod
) then
3200 -- Insertion after an abort deferred block
3202 if Present
(Body_Ins
) then
3203 Finalizer_Insert_Nod
:= Body_Ins
;
3205 Finalizer_Insert_Nod
:= Inc_Decl
;
3209 -- Create the associated label with this object, generate:
3211 -- L<counter> : label;
3214 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3216 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3217 Label
:= Make_Label
(Loc
, Label_Id
);
3219 Prepend_To
(Finalizer_Decls
,
3220 Make_Implicit_Label_Declaration
(Loc
,
3221 Defining_Identifier
=> Entity
(Label_Id
),
3222 Label_Construct
=> Label
));
3224 -- Create the associated jump with this object, generate:
3226 -- when <counter> =>
3229 Prepend_To
(Jump_Alts
,
3230 Make_Case_Statement_Alternative
(Loc
,
3231 Discrete_Choices
=> New_List
(
3232 Make_Integer_Literal
(Loc
, Counter_Val
)),
3233 Statements
=> New_List
(
3234 Make_Goto_Statement
(Loc
,
3235 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3237 -- Insert the jump destination, generate:
3241 Append_To
(Finalizer_Stmts
, Label
);
3243 -- Disable warnings on Obj_Id. This works around an issue where GCC
3244 -- is not able to detect that Obj_Id is protected by a counter and
3245 -- emits spurious warnings.
3247 if not Comes_From_Source
(Obj_Id
) then
3248 Set_Warnings_Off
(Obj_Id
);
3251 -- Processing for simple protected objects. Such objects require
3252 -- manual finalization of their lock managers.
3254 if Is_Protected
then
3255 if Is_Simple_Protected_Type
(Obj_Typ
) then
3256 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3258 if Present
(Fin_Call
) then
3259 Fin_Stmts
:= New_List
(Fin_Call
);
3262 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3263 if Is_Record_Type
(Obj_Typ
) then
3264 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3265 elsif Is_Array_Type
(Obj_Typ
) then
3266 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3272 -- System.Tasking.Protected_Objects.Finalize_Protection
3280 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3281 Fin_Stmts
:= New_List
(
3282 Make_Block_Statement
(Loc
,
3283 Handled_Statement_Sequence
=>
3284 Make_Handled_Sequence_Of_Statements
(Loc
,
3285 Statements
=> Fin_Stmts
,
3287 Exception_Handlers
=> New_List
(
3288 Make_Exception_Handler
(Loc
,
3289 Exception_Choices
=> New_List
(
3290 Make_Others_Choice
(Loc
)),
3292 Statements
=> New_List
(
3293 Make_Null_Statement
(Loc
)))))));
3296 -- Processing for regular controlled objects
3301 -- [Deep_]Finalize (Obj);
3304 -- when Id : others =>
3305 -- if not Raised then
3307 -- Save_Occurrence (E, Id);
3316 -- Guard against a missing [Deep_]Finalize when the object type
3317 -- was not properly frozen.
3319 if No
(Fin_Call
) then
3320 Fin_Call
:= Make_Null_Statement
(Loc
);
3323 -- For CodePeer, the exception handlers normally generated here
3324 -- generate complex flowgraphs which result in capacity problems.
3325 -- Omitting these handlers for CodePeer is justified as follows:
3327 -- If a handler is dead, then omitting it is surely ok
3329 -- If a handler is live, then CodePeer should flag the
3330 -- potentially-exception-raising construct that causes it
3331 -- to be live. That is what we are interested in, not what
3332 -- happens after the exception is raised.
3334 if Exceptions_OK
and not CodePeer_Mode
then
3335 Fin_Stmts
:= New_List
(
3336 Make_Block_Statement
(Loc
,
3337 Handled_Statement_Sequence
=>
3338 Make_Handled_Sequence_Of_Statements
(Loc
,
3339 Statements
=> New_List
(Fin_Call
),
3341 Exception_Handlers
=> New_List
(
3342 Build_Exception_Handler
3343 (Finalizer_Data
, For_Package
)))));
3345 -- When exception handlers are prohibited, the finalization call
3346 -- appears unprotected. Any exception raised during finalization
3347 -- will bypass the circuitry which ensures the cleanup of all
3348 -- remaining objects.
3351 Fin_Stmts
:= New_List
(Fin_Call
);
3354 -- If we are dealing with a return object of a build-in-place
3355 -- function, generate the following cleanup statements:
3357 -- if BIPallocfrom > Secondary_Stack'Pos
3358 -- and then BIPfinalizationmaster /= null
3361 -- type Ptr_Typ is access Obj_Typ;
3362 -- for Ptr_Typ'Storage_Pool use
3363 -- Base_Pool (BIPfinalizationmaster.all).all;
3365 -- Free (Ptr_Typ (Temp));
3369 -- The generated code effectively detaches the temporary from the
3370 -- caller finalization master and deallocates the object.
3372 if Is_Return_Object
(Obj_Id
) then
3374 Func_Id
: constant Entity_Id
:=
3375 Return_Applies_To
(Scope
(Obj_Id
));
3378 if Is_Build_In_Place_Function
(Func_Id
)
3379 and then Needs_BIP_Finalization_Master
(Func_Id
)
3381 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3386 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3387 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3389 -- Temporaries created for the purpose of "exporting" a
3390 -- transient object out of an Expression_With_Actions (EWA)
3391 -- need guards. The following illustrates the usage of such
3394 -- Access_Typ : access [all] Obj_Typ;
3395 -- Temp : Access_Typ := null;
3396 -- <Counter> := ...;
3399 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3400 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3402 -- Temp := Ctrl_Trans'Unchecked_Access;
3405 -- The finalization machinery does not process EWA nodes as
3406 -- this may lead to premature finalization of expressions. Note
3407 -- that Temp is marked as being properly initialized regardless
3408 -- of whether the initialization of Ctrl_Trans succeeded. Since
3409 -- a failed initialization may leave Temp with a value of null,
3410 -- add a guard to handle this case:
3412 -- if Obj /= null then
3413 -- <object finalization statements>
3416 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3417 N_Object_Declaration
3419 Fin_Stmts
:= New_List
(
3420 Make_If_Statement
(Loc
,
3423 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3424 Right_Opnd
=> Make_Null
(Loc
)),
3425 Then_Statements
=> Fin_Stmts
));
3427 -- Return objects use a flag to aid in processing their
3428 -- potential finalization when the enclosing function fails
3429 -- to return properly. Generate:
3432 -- <object finalization statements>
3436 Fin_Stmts
:= New_List
(
3437 Make_If_Statement
(Loc
,
3442 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3444 Then_Statements
=> Fin_Stmts
));
3449 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3451 -- Since the declarations are examined in reverse, the state counter
3452 -- must be decremented in order to keep with the true position of
3455 Counter_Val
:= Counter_Val
- 1;
3456 end Process_Object_Declaration
;
3458 -------------------------------------
3459 -- Process_Tagged_Type_Declaration --
3460 -------------------------------------
3462 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3463 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3464 DT_Ptr
: constant Entity_Id
:=
3465 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3468 -- Ada.Tags.Unregister_Tag (<Typ>P);
3470 Append_To
(Tagged_Type_Stmts
,
3471 Make_Procedure_Call_Statement
(Loc
,
3473 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3474 Parameter_Associations
=> New_List
(
3475 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3476 end Process_Tagged_Type_Declaration
;
3478 -- Start of processing for Build_Finalizer
3483 -- Do not perform this expansion in SPARK mode because it is not
3486 if GNATprove_Mode
then
3490 -- Step 1: Extract all lists which may contain controlled objects or
3491 -- library-level tagged types.
3493 if For_Package_Spec
then
3494 Decls
:= Visible_Declarations
(Specification
(N
));
3495 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3497 -- Retrieve the package spec id
3499 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3501 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3502 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3505 -- Accept statement, block, entry body, package body, protected body,
3506 -- subprogram body or task body.
3509 Decls
:= Declarations
(N
);
3510 HSS
:= Handled_Statement_Sequence
(N
);
3512 if Present
(HSS
) then
3513 if Present
(Statements
(HSS
)) then
3514 Stmts
:= Statements
(HSS
);
3517 if Present
(At_End_Proc
(HSS
)) then
3518 Prev_At_End
:= At_End_Proc
(HSS
);
3522 -- Retrieve the package spec id for package bodies
3524 if For_Package_Body
then
3525 Spec_Id
:= Corresponding_Spec
(N
);
3529 -- Do not process nested packages since those are handled by the
3530 -- enclosing scope's finalizer. Do not process non-expanded package
3531 -- instantiations since those will be re-analyzed and re-expanded.
3535 (not Is_Library_Level_Entity
(Spec_Id
)
3537 -- Nested packages are library level entities, but do not need to
3538 -- be processed separately.
3540 or else Scope_Depth
(Spec_Id
) /= Uint_1
3541 or else (Is_Generic_Instance
(Spec_Id
)
3542 and then Package_Instantiation
(Spec_Id
) /= N
))
3544 -- Still need to process package body instantiations which may
3545 -- contain objects requiring finalization.
3549 and then Is_Library_Level_Entity
(Spec_Id
)
3550 and then Is_Generic_Instance
(Spec_Id
))
3555 -- Step 2: Object [pre]processing
3559 -- Preprocess the visible declarations now in order to obtain the
3560 -- correct number of controlled object by the time the private
3561 -- declarations are processed.
3563 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3565 -- From all the possible contexts, only package specifications may
3566 -- have private declarations.
3568 if For_Package_Spec
then
3569 Process_Declarations
3570 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3573 -- The current context may lack controlled objects, but require some
3574 -- other form of completion (task termination for instance). In such
3575 -- cases, the finalizer must be created and carry the additional
3578 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3582 -- The preprocessing has determined that the context has controlled
3583 -- objects or library-level tagged types.
3585 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3587 -- Private declarations are processed first in order to preserve
3588 -- possible dependencies between public and private objects.
3590 if For_Package_Spec
then
3591 Process_Declarations
(Priv_Decls
);
3594 Process_Declarations
(Decls
);
3600 -- Preprocess both declarations and statements
3602 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3603 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3605 -- At this point it is known that N has controlled objects. Ensure
3606 -- that N has a declarative list since the finalizer spec will be
3609 if Has_Ctrl_Objs
and then No
(Decls
) then
3610 Set_Declarations
(N
, New_List
);
3611 Decls
:= Declarations
(N
);
3612 Spec_Decls
:= Decls
;
3615 -- The current context may lack controlled objects, but require some
3616 -- other form of completion (task termination for instance). In such
3617 -- cases, the finalizer must be created and carry the additional
3620 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3624 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3625 Process_Declarations
(Stmts
);
3626 Process_Declarations
(Decls
);
3630 -- Step 3: Finalizer creation
3632 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3635 end Build_Finalizer
;
3637 --------------------------
3638 -- Build_Finalizer_Call --
3639 --------------------------
3641 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3643 -- Do not perform this expansion in SPARK mode because we do not create
3644 -- finalizers in the first place.
3646 if GNATprove_Mode
then
3650 -- If the construct to be cleaned up is a protected subprogram body, the
3651 -- finalizer call needs to be associated with the block that wraps the
3652 -- unprotected version of the subprogram. The following illustrates this
3655 -- procedure Prot_SubpP is
3656 -- procedure finalizer is
3658 -- Service_Entries (Prot_Obj);
3665 -- Prot_SubpN (Prot_Obj);
3672 Loc
: constant Source_Ptr
:= Sloc
(N
);
3674 Is_Protected_Subp_Body
: constant Boolean :=
3675 Nkind
(N
) = N_Subprogram_Body
3676 and then Is_Protected_Subprogram_Body
(N
);
3677 -- True if N is the protected version of a subprogram that belongs to
3678 -- a protected type.
3680 HSS
: constant Node_Id
:=
3681 (if Is_Protected_Subp_Body
3682 then Handled_Statement_Sequence
3683 (Last
(Statements
(Handled_Statement_Sequence
(N
))))
3684 else Handled_Statement_Sequence
(N
));
3686 -- We attach the At_End_Proc to the HSS if this is an accept
3687 -- statement or extended return statement. Also in the case of
3688 -- a protected subprogram, because if Service_Entries raises an
3689 -- exception, we do not lock the PO, so we also do not want to
3692 Use_HSS
: constant Boolean :=
3693 Nkind
(N
) in N_Accept_Statement | N_Extended_Return_Statement
3694 or else Is_Protected_Subp_Body
;
3696 At_End_Proc_Bearer
: constant Node_Id
:= (if Use_HSS
then HSS
else N
);
3698 pragma Assert
(No
(At_End_Proc
(At_End_Proc_Bearer
)));
3699 Set_At_End_Proc
(At_End_Proc_Bearer
, New_Occurrence_Of
(Fin_Id
, Loc
));
3700 -- Attach reference to finalizer to tree, for LLVM use
3701 Set_Parent
(At_End_Proc
(At_End_Proc_Bearer
), At_End_Proc_Bearer
);
3702 Analyze
(At_End_Proc
(At_End_Proc_Bearer
));
3703 Expand_At_End_Handler
(At_End_Proc_Bearer
, Empty
);
3705 end Build_Finalizer_Call
;
3707 ---------------------
3708 -- Build_Late_Proc --
3709 ---------------------
3711 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3713 for Final_Prim
in Name_Of
'Range loop
3714 if Name_Of
(Final_Prim
) = Nam
then
3717 (Prim
=> Final_Prim
,
3719 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3722 end Build_Late_Proc
;
3724 -------------------------------
3725 -- Build_Object_Declarations --
3726 -------------------------------
3728 procedure Build_Object_Declarations
3729 (Data
: out Finalization_Exception_Data
;
3732 For_Package
: Boolean := False)
3737 -- This variable captures an unused dummy internal entity, see the
3738 -- comment associated with its use.
3741 pragma Assert
(Decls
/= No_List
);
3743 -- Always set the proper location as it may be needed even when
3744 -- exception propagation is forbidden.
3748 if Restriction_Active
(No_Exception_Propagation
) then
3749 Data
.Abort_Id
:= Empty
;
3751 Data
.Raised_Id
:= Empty
;
3755 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3757 -- In certain scenarios, finalization can be triggered by an abort. If
3758 -- the finalization itself fails and raises an exception, the resulting
3759 -- Program_Error must be supressed and replaced by an abort signal. In
3760 -- order to detect this scenario, save the state of entry into the
3761 -- finalization code.
3763 -- This is not needed for library-level finalizers as they are called by
3764 -- the environment task and cannot be aborted.
3766 if not For_Package
then
3767 if Abort_Allowed
then
3768 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3771 -- Abort_Id : constant Boolean := <A_Expr>;
3774 Make_Object_Declaration
(Loc
,
3775 Defining_Identifier
=> Data
.Abort_Id
,
3776 Constant_Present
=> True,
3777 Object_Definition
=>
3778 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3780 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3782 -- Abort is not required
3785 -- Generate a dummy entity to ensure that the internal symbols are
3786 -- in sync when a unit is compiled with and without aborts.
3788 Dummy
:= Make_Temporary
(Loc
, 'A');
3789 Data
.Abort_Id
:= Empty
;
3792 -- Library-level finalizers
3795 Data
.Abort_Id
:= Empty
;
3798 if Exception_Extra_Info
then
3799 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3802 -- E_Id : Exception_Occurrence;
3805 Make_Object_Declaration
(Loc
,
3806 Defining_Identifier
=> Data
.E_Id
,
3807 Object_Definition
=>
3808 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3809 Set_No_Initialization
(Decl
);
3811 Append_To
(Decls
, Decl
);
3818 -- Raised_Id : Boolean := False;
3821 Make_Object_Declaration
(Loc
,
3822 Defining_Identifier
=> Data
.Raised_Id
,
3823 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3824 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3826 if Debug_Generated_Code
then
3827 Set_Debug_Info_Needed
(Data
.Raised_Id
);
3829 end Build_Object_Declarations
;
3831 ---------------------------
3832 -- Build_Raise_Statement --
3833 ---------------------------
3835 function Build_Raise_Statement
3836 (Data
: Finalization_Exception_Data
) return Node_Id
3842 -- Standard run-time use the specialized routine
3843 -- Raise_From_Controlled_Operation.
3845 if Exception_Extra_Info
3846 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3849 Make_Procedure_Call_Statement
(Data
.Loc
,
3852 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3853 Parameter_Associations
=>
3854 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3856 -- Restricted run-time: exception messages are not supported and hence
3857 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3862 Make_Raise_Program_Error
(Data
.Loc
,
3863 Reason
=> PE_Finalize_Raised_Exception
);
3868 -- Raised_Id and then not Abort_Id
3872 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3874 if Present
(Data
.Abort_Id
) then
3875 Expr
:= Make_And_Then
(Data
.Loc
,
3878 Make_Op_Not
(Data
.Loc
,
3879 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3884 -- if Raised_Id and then not Abort_Id then
3885 -- Raise_From_Controlled_Operation (E_Id);
3887 -- raise Program_Error; -- restricted runtime
3891 Make_If_Statement
(Data
.Loc
,
3893 Then_Statements
=> New_List
(Stmt
));
3894 end Build_Raise_Statement
;
3896 -----------------------------
3897 -- Build_Record_Deep_Procs --
3898 -----------------------------
3900 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3904 (Prim
=> Initialize_Case
,
3906 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3908 if not Is_Limited_View
(Typ
) then
3911 (Prim
=> Adjust_Case
,
3913 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3916 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3917 -- suppressed since these routine will not be used.
3919 if not Restriction_Active
(No_Finalization
) then
3922 (Prim
=> Finalize_Case
,
3924 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3926 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3928 if not CodePeer_Mode
then
3931 (Prim
=> Address_Case
,
3933 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3936 end Build_Record_Deep_Procs
;
3942 function Cleanup_Array
3945 Typ
: Entity_Id
) return List_Id
3947 Loc
: constant Source_Ptr
:= Sloc
(N
);
3948 Index_List
: constant List_Id
:= New_List
;
3950 function Free_Component
return List_Id
;
3951 -- Generate the code to finalize the task or protected subcomponents
3952 -- of a single component of the array.
3954 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3955 -- Generate a loop over one dimension of the array
3957 --------------------
3958 -- Free_Component --
3959 --------------------
3961 function Free_Component
return List_Id
is
3962 Stmts
: List_Id
:= New_List
;
3964 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3967 -- Component type is known to contain tasks or protected objects
3970 Make_Indexed_Component
(Loc
,
3971 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3972 Expressions
=> Index_List
);
3974 Set_Etype
(Tsk
, C_Typ
);
3976 if Is_Task_Type
(C_Typ
) then
3977 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3979 elsif Is_Simple_Protected_Type
(C_Typ
) then
3980 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3982 elsif Is_Record_Type
(C_Typ
) then
3983 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3985 elsif Is_Array_Type
(C_Typ
) then
3986 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3992 ------------------------
3993 -- Free_One_Dimension --
3994 ------------------------
3996 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
4000 if Dim
> Number_Dimensions
(Typ
) then
4001 return Free_Component
;
4003 -- Here we generate the required loop
4006 Index
:= Make_Temporary
(Loc
, 'J');
4007 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
4010 Make_Implicit_Loop_Statement
(N
,
4011 Identifier
=> Empty
,
4013 Make_Iteration_Scheme
(Loc
,
4014 Loop_Parameter_Specification
=>
4015 Make_Loop_Parameter_Specification
(Loc
,
4016 Defining_Identifier
=> Index
,
4017 Discrete_Subtype_Definition
=>
4018 Make_Attribute_Reference
(Loc
,
4019 Prefix
=> Duplicate_Subexpr
(Obj
),
4020 Attribute_Name
=> Name_Range
,
4021 Expressions
=> New_List
(
4022 Make_Integer_Literal
(Loc
, Dim
))))),
4023 Statements
=> Free_One_Dimension
(Dim
+ 1)));
4025 end Free_One_Dimension
;
4027 -- Start of processing for Cleanup_Array
4030 return Free_One_Dimension
(1);
4033 --------------------
4034 -- Cleanup_Record --
4035 --------------------
4037 function Cleanup_Record
4040 Typ
: Entity_Id
) return List_Id
4042 Loc
: constant Source_Ptr
:= Sloc
(N
);
4043 Stmts
: constant List_Id
:= New_List
;
4044 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
4050 if Has_Discriminants
(U_Typ
)
4051 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
4052 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
4055 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
4057 -- For now, do not attempt to free a component that may appear in a
4058 -- variant, and instead issue a warning. Doing this "properly" would
4059 -- require building a case statement and would be quite a mess. Note
4060 -- that the RM only requires that free "work" for the case of a task
4061 -- access value, so already we go way beyond this in that we deal
4062 -- with the array case and non-discriminated record cases.
4065 ("task/protected object in variant record will not be freed??", N
);
4066 return New_List
(Make_Null_Statement
(Loc
));
4069 Comp
:= First_Component
(U_Typ
);
4070 while Present
(Comp
) loop
4071 if Chars
(Comp
) /= Name_uParent
4072 and then (Has_Task
(Etype
(Comp
))
4073 or else Has_Simple_Protected_Object
(Etype
(Comp
)))
4076 Make_Selected_Component
(Loc
,
4077 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
4078 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
4079 Set_Etype
(Tsk
, Etype
(Comp
));
4081 if Is_Task_Type
(Etype
(Comp
)) then
4082 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
4084 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
4085 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
4087 elsif Is_Record_Type
(Etype
(Comp
)) then
4089 -- Recurse, by generating the prefix of the argument to the
4090 -- eventual cleanup call.
4092 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
4094 elsif Is_Array_Type
(Etype
(Comp
)) then
4095 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
4099 Next_Component
(Comp
);
4105 ------------------------------
4106 -- Cleanup_Protected_Object --
4107 ------------------------------
4109 function Cleanup_Protected_Object
4111 Ref
: Node_Id
) return Node_Id
4113 Loc
: constant Source_Ptr
:= Sloc
(N
);
4116 -- For restricted run-time libraries (Ravenscar), tasks are
4117 -- non-terminating, and protected objects can only appear at library
4118 -- level, so we do not want finalization of protected objects.
4120 if Restricted_Profile
then
4125 Make_Procedure_Call_Statement
(Loc
,
4127 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4128 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4130 end Cleanup_Protected_Object
;
4136 function Cleanup_Task
4138 Ref
: Node_Id
) return Node_Id
4140 Loc
: constant Source_Ptr
:= Sloc
(N
);
4143 -- For restricted run-time libraries (Ravenscar), tasks are
4144 -- non-terminating and they can only appear at library level,
4145 -- so we do not want finalization of task objects.
4147 if Restricted_Profile
then
4152 Make_Procedure_Call_Statement
(Loc
,
4154 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4155 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4159 --------------------------------------
4160 -- Check_Unnesting_Elaboration_Code --
4161 --------------------------------------
4163 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4164 Loc
: constant Source_Ptr
:= Sloc
(N
);
4165 Block_Elab_Proc
: Entity_Id
:= Empty
;
4167 procedure Set_Block_Elab_Proc
;
4168 -- Create a defining identifier for a procedure that will replace
4169 -- a block with nested subprograms (unless it has already been created,
4170 -- in which case this is a no-op).
4172 procedure Set_Block_Elab_Proc
is
4174 if No
(Block_Elab_Proc
) then
4175 Block_Elab_Proc
:= Make_Temporary
(Loc
, 'I');
4177 end Set_Block_Elab_Proc
;
4179 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4180 -- Find entities in the elaboration code of a library package body that
4181 -- contain or represent a subprogram body. A body can appear within a
4182 -- block or a loop or can appear by itself if generated for an object
4183 -- declaration that involves controlled actions. The first such entity
4184 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4185 -- that will be used to reset the scopes of all entities that become
4186 -- local to the new elaboration procedure. This is needed for subsequent
4187 -- unnesting actions, which depend on proper setting of the Scope links
4188 -- to determine the nesting level of each subprogram.
4190 -----------------------
4191 -- Find_Local_Scope --
4192 -----------------------
4194 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4201 while Present
(Stat
) loop
4202 case Nkind
(Stat
) is
4203 when N_Block_Statement
=>
4204 if Present
(Identifier
(Stat
)) then
4205 Id
:= Entity
(Identifier
(Stat
));
4207 -- The Scope of this block needs to be reset to the new
4208 -- procedure if the block contains nested subprograms.
4210 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4211 Set_Block_Elab_Proc
;
4212 Set_Scope
(Id
, Block_Elab_Proc
);
4216 when N_Loop_Statement
=>
4217 Id
:= Entity
(Identifier
(Stat
));
4219 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4220 if Scope
(Id
) = Current_Scope
then
4221 Set_Block_Elab_Proc
;
4222 Set_Scope
(Id
, Block_Elab_Proc
);
4226 -- We traverse the loop's statements as well, which may
4227 -- include other block (etc.) statements that need to have
4228 -- their Scope set to Block_Elab_Proc. (Is this really the
4229 -- case, or do such nested blocks refer to the loop scope
4230 -- rather than the loop's enclosing scope???.)
4232 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4234 when N_If_Statement
=>
4235 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4236 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4238 Node
:= First
(Elsif_Parts
(Stat
));
4239 while Present
(Node
) loop
4240 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4244 when N_Case_Statement
=>
4245 Node
:= First
(Alternatives
(Stat
));
4246 while Present
(Node
) loop
4247 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4251 -- Reset the Scope of a subprogram occurring at the top level
4253 when N_Subprogram_Body
=>
4254 Id
:= Defining_Entity
(Stat
);
4256 Set_Block_Elab_Proc
;
4257 Set_Scope
(Id
, Block_Elab_Proc
);
4265 end Reset_Scopes_To_Block_Elab_Proc
;
4269 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4270 Elab_Body
: Node_Id
;
4271 Elab_Call
: Node_Id
;
4273 -- Start of processing for Check_Unnesting_Elaboration_Code
4276 if Present
(H_Seq
) then
4277 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4279 -- There may be subprograms declared in the exception handlers
4280 -- of the current body.
4282 if Present
(Exception_Handlers
(H_Seq
)) then
4284 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4286 while Present
(Handler
) loop
4287 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4294 if Present
(Block_Elab_Proc
) then
4296 Make_Subprogram_Body
(Loc
,
4298 Make_Procedure_Specification
(Loc
,
4299 Defining_Unit_Name
=> Block_Elab_Proc
),
4300 Declarations
=> New_List
,
4301 Handled_Statement_Sequence
=>
4302 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4305 Make_Procedure_Call_Statement
(Loc
,
4306 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4308 Append_To
(Declarations
(N
), Elab_Body
);
4309 Analyze
(Elab_Body
);
4310 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4312 Set_Handled_Statement_Sequence
(N
,
4313 Make_Handled_Sequence_Of_Statements
(Loc
,
4314 Statements
=> New_List
(Elab_Call
)));
4316 Analyze
(Elab_Call
);
4318 -- Could we reset the scopes of entities associated with the new
4319 -- procedure here via a loop over entities rather than doing it in
4320 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4323 end Check_Unnesting_Elaboration_Code
;
4325 ---------------------------------------
4326 -- Check_Unnesting_In_Decls_Or_Stmts --
4327 ---------------------------------------
4329 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4330 Decl_Or_Stmt
: Node_Id
;
4333 if Unnest_Subprogram_Mode
4334 and then Present
(Decls_Or_Stmts
)
4336 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4337 while Present
(Decl_Or_Stmt
) loop
4338 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4339 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4341 Unnest_Block
(Decl_Or_Stmt
);
4343 -- If-statements may contain subprogram bodies at the outer level
4344 -- of their statement lists, and the subprograms may make up-level
4345 -- references (such as to objects declared in the same statement
4346 -- list). Unlike block and loop cases, however, we don't have an
4347 -- entity on which to test the Contains_Subprogram flag, so
4348 -- Unnest_If_Statement must traverse the statement lists to
4349 -- determine whether there are nested subprograms present.
4351 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4352 Unnest_If_Statement
(Decl_Or_Stmt
);
4354 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4356 Id
: constant Entity_Id
:=
4357 Entity
(Identifier
(Decl_Or_Stmt
));
4360 -- When a top-level loop within declarations of a library
4361 -- package spec or body contains nested subprograms, we wrap
4362 -- it in a procedure to handle possible up-level references
4363 -- to entities associated with the loop (such as loop
4366 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4367 Unnest_Loop
(Decl_Or_Stmt
);
4371 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4372 and then not Modify_Tree_For_C
4374 Check_Unnesting_In_Decls_Or_Stmts
4375 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4376 Check_Unnesting_In_Decls_Or_Stmts
4377 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4379 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4380 and then not Modify_Tree_For_C
4382 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4383 if Present
(Statements
4384 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4386 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4387 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4388 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4392 Next
(Decl_Or_Stmt
);
4395 end Check_Unnesting_In_Decls_Or_Stmts
;
4397 ---------------------------------
4398 -- Check_Unnesting_In_Handlers --
4399 ---------------------------------
4401 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4402 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4405 if Present
(Stmt_Seq
)
4406 and then Present
(Exception_Handlers
(Stmt_Seq
))
4409 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4411 while Present
(Handler
) loop
4412 if Present
(Statements
(Handler
)) then
4413 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4420 end Check_Unnesting_In_Handlers
;
4422 ------------------------------
4423 -- Check_Visibly_Controlled --
4424 ------------------------------
4426 procedure Check_Visibly_Controlled
4427 (Prim
: Final_Primitives
;
4429 E
: in out Entity_Id
;
4430 Cref
: in out Node_Id
)
4432 Parent_Type
: Entity_Id
;
4436 if Is_Derived_Type
(Typ
)
4437 and then Comes_From_Source
(E
)
4438 and then No
(Overridden_Operation
(E
))
4440 -- We know that the explicit operation on the type does not override
4441 -- the inherited operation of the parent, and that the derivation
4442 -- is from a private type that is not visibly controlled.
4444 Parent_Type
:= Etype
(Typ
);
4445 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4447 if Present
(Op
) then
4450 -- Wrap the object to be initialized into the proper
4451 -- unchecked conversion, to be compatible with the operation
4454 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4455 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4457 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4461 end Check_Visibly_Controlled
;
4463 --------------------------
4464 -- Contains_Subprogram --
4465 --------------------------
4467 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4471 E
:= First_Entity
(Blk
);
4473 while Present
(E
) loop
4474 if Is_Subprogram
(E
) then
4477 elsif Ekind
(E
) in E_Block | E_Loop
4478 and then Contains_Subprogram
(E
)
4487 end Contains_Subprogram
;
4493 function Convert_View
4496 Ind
: Pos
:= 1) return Node_Id
4498 Fent
: Entity_Id
:= First_Entity
(Proc
);
4503 for J
in 2 .. Ind
loop
4507 Ftyp
:= Etype
(Fent
);
4509 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
4510 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4512 Atyp
:= Etype
(Arg
);
4515 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4516 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4519 and then Present
(Atyp
)
4520 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
4521 and then Base_Type
(Underlying_Type
(Atyp
)) =
4522 Base_Type
(Underlying_Type
(Ftyp
))
4524 return Unchecked_Convert_To
(Ftyp
, Arg
);
4526 -- If the argument is already a conversion, as generated by
4527 -- Make_Init_Call, set the target type to the type of the formal
4528 -- directly, to avoid spurious typing problems.
4530 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
4531 and then not Is_Class_Wide_Type
(Atyp
)
4533 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4534 Set_Etype
(Arg
, Ftyp
);
4537 -- Otherwise, introduce a conversion when the designated object
4538 -- has a type derived from the formal of the controlled routine.
4540 elsif Is_Private_Type
(Ftyp
)
4541 and then Present
(Atyp
)
4542 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4544 return Unchecked_Convert_To
(Ftyp
, Arg
);
4551 -------------------------------
4552 -- Establish_Transient_Scope --
4553 -------------------------------
4555 -- This procedure is called each time a transient block has to be inserted
4556 -- that is to say for each call to a function with unconstrained or tagged
4557 -- result. It creates a new scope on the scope stack in order to enclose
4558 -- all transient variables generated.
4560 procedure Establish_Transient_Scope
4562 Manage_Sec_Stack
: Boolean)
4564 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4565 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4567 function Find_Enclosing_Transient_Scope
return Entity_Id
;
4568 -- Examine the scope stack looking for the nearest enclosing transient
4569 -- scope within the innermost enclosing package or subprogram. Return
4570 -- Empty if no such scope exists.
4572 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
4573 -- Locate a suitable context for arbitrary node N which may need to be
4574 -- serviced by a transient scope. Return Empty if no suitable context
4577 procedure Delegate_Sec_Stack_Management
;
4578 -- Move the management of the secondary stack to the nearest enclosing
4581 procedure Create_Transient_Scope
(Context
: Node_Id
);
4582 -- Place a new scope on the scope stack in order to service construct
4583 -- Context. Context is the node found by Find_Transient_Context. The
4584 -- new scope may also manage the secondary stack.
4586 ----------------------------
4587 -- Create_Transient_Scope --
4588 ----------------------------
4590 procedure Create_Transient_Scope
(Context
: Node_Id
) is
4591 Loc
: constant Source_Ptr
:= Sloc
(N
);
4593 Iter_Loop
: Entity_Id
;
4594 Trans_Scop
: constant Entity_Id
:=
4595 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4598 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4600 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4603 Push_Scope
(Trans_Scop
);
4604 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
4605 Set_Scope_Is_Transient
;
4607 -- The transient scope must also manage the secondary stack
4609 if Manage_Sec_Stack
then
4610 Set_Uses_Sec_Stack
(Trans_Scop
);
4611 Check_Restriction
(No_Secondary_Stack
, N
);
4613 -- The expansion of iterator loops generates references to objects
4614 -- in order to extract elements from a container:
4616 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4617 -- Obj : <object type> renames Ref.all.Element.all;
4619 -- These references are controlled and returned on the secondary
4620 -- stack. A new reference is created at each iteration of the loop
4621 -- and as a result it must be finalized and the space occupied by
4622 -- it on the secondary stack reclaimed at the end of the current
4625 -- When the context that requires a transient scope is a call to
4626 -- routine Reference, the node to be wrapped is the source object:
4628 -- for Obj of Container loop
4630 -- Routine Wrap_Transient_Declaration however does not generate
4631 -- a physical block as wrapping a declaration will kill it too
4632 -- early. To handle this peculiar case, mark the related iterator
4633 -- loop as requiring the secondary stack. This signals the
4634 -- finalization machinery to manage the secondary stack (see
4635 -- routine Process_Statements_For_Controlled_Objects).
4637 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4639 if Present
(Iter_Loop
) then
4640 Set_Uses_Sec_Stack
(Iter_Loop
);
4644 if Debug_Flag_W
then
4645 Write_Str
(" <Transient>");
4648 end Create_Transient_Scope
;
4650 -----------------------------------
4651 -- Delegate_Sec_Stack_Management --
4652 -----------------------------------
4654 procedure Delegate_Sec_Stack_Management
is
4656 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4658 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4660 -- Prevent the search from going too far or within the scope
4661 -- space of another unit.
4663 if Scope
.Entity
= Standard_Standard
then
4666 -- No transient scope should be encountered during the
4667 -- traversal because Establish_Transient_Scope should have
4668 -- already handled this case.
4670 elsif Scope
.Is_Transient
then
4671 raise Program_Error
;
4673 -- The construct that requires secondary stack management is
4674 -- always enclosed by a package or subprogram scope.
4676 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
4677 Set_Uses_Sec_Stack
(Scope
.Entity
);
4678 Check_Restriction
(No_Secondary_Stack
, N
);
4685 -- At this point no suitable scope was found. This should never occur
4686 -- because a construct is always enclosed by a compilation unit which
4689 pragma Assert
(False);
4690 end Delegate_Sec_Stack_Management
;
4692 ------------------------------------
4693 -- Find_Enclosing_Transient_Scope --
4694 ------------------------------------
4696 function Find_Enclosing_Transient_Scope
return Entity_Id
is
4698 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4700 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4702 -- Prevent the search from going too far or within the scope
4703 -- space of another unit.
4705 if Scope
.Entity
= Standard_Standard
4706 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
4710 elsif Scope
.Is_Transient
then
4711 return Scope
.Entity
;
4717 end Find_Enclosing_Transient_Scope
;
4719 ----------------------------
4720 -- Find_Transient_Context --
4721 ----------------------------
4723 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
4724 Curr
: Node_Id
:= N
;
4725 Prev
: Node_Id
:= Empty
;
4728 while Present
(Curr
) loop
4729 case Nkind
(Curr
) is
4733 -- Declarations act as a boundary for a transient scope even if
4734 -- they are not wrapped, see Wrap_Transient_Declaration.
4736 when N_Object_Declaration
4737 | N_Object_Renaming_Declaration
4738 | N_Subtype_Declaration
4744 -- Statements and statement-like constructs act as a boundary
4745 -- for a transient scope.
4747 when N_Accept_Alternative
4748 | N_Attribute_Definition_Clause
4750 | N_Case_Statement_Alternative
4752 | N_Delay_Alternative
4753 | N_Delay_Until_Statement
4754 | N_Delay_Relative_Statement
4755 | N_Discriminant_Association
4757 | N_Entry_Body_Formal_Part
4760 | N_Iteration_Scheme
4761 | N_Terminate_Alternative
4763 pragma Assert
(Present
(Prev
));
4766 when N_Assignment_Statement
=>
4769 when N_Entry_Call_Statement
4770 | N_Procedure_Call_Statement
4772 -- When an entry or procedure call acts as the alternative
4773 -- of a conditional or timed entry call, the proper context
4774 -- is that of the alternative.
4776 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
4777 and then Nkind
(Parent
(Parent
(Curr
))) in
4778 N_Conditional_Entry_Call | N_Timed_Entry_Call
4780 return Parent
(Parent
(Curr
));
4782 -- General case for entry or procedure calls
4790 -- Pragma Check is not a valid transient context in
4791 -- GNATprove mode because the pragma must remain unchanged.
4794 and then Get_Pragma_Id
(Curr
) = Pragma_Check
4798 -- General case for pragmas
4804 when N_Raise_Statement
=>
4807 when N_Simple_Return_Statement
=>
4809 -- A return statement is not a valid transient context when
4810 -- the function itself requires transient scope management
4811 -- because the result will be reclaimed too early.
4813 if Requires_Transient_Scope
(Etype
4814 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
4818 -- General case for return statements
4826 when N_Attribute_Reference
=>
4827 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
4831 -- An Ada 2012 iterator specification is not a valid context
4832 -- because Analyze_Iterator_Specification already employs
4833 -- special processing for it.
4835 when N_Iterator_Specification
=>
4838 when N_Loop_Parameter_Specification
=>
4840 -- An iteration scheme is not a valid context because
4841 -- routine Analyze_Iteration_Scheme already employs
4842 -- special processing.
4844 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
4847 return Parent
(Curr
);
4852 -- The following nodes represent "dummy contexts" which do not
4853 -- need to be wrapped.
4855 when N_Component_Declaration
4856 | N_Discriminant_Specification
4857 | N_Parameter_Specification
4861 -- If the traversal leaves a scope without having been able to
4862 -- find a construct to wrap, something is going wrong, but this
4863 -- can happen in error situations that are not detected yet
4864 -- (such as a dynamic string in a pragma Export).
4866 when N_Block_Statement
4869 | N_Package_Declaration
4883 Curr
:= Parent
(Curr
);
4887 end Find_Transient_Context
;
4889 ------------------------------
4890 -- Is_Package_Or_Subprogram --
4891 ------------------------------
4893 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4895 return Ekind
(Id
) in E_Entry
4900 | E_Subprogram_Body
;
4901 end Is_Package_Or_Subprogram
;
4905 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
4908 -- Start of processing for Establish_Transient_Scope
4911 -- Do not create a new transient scope if there is already an enclosing
4912 -- transient scope within the innermost enclosing package or subprogram.
4914 if Present
(Trans_Id
) then
4916 -- If the transient scope was requested for purposes of managing the
4917 -- secondary stack, then the existing scope must perform this task.
4919 if Manage_Sec_Stack
then
4920 Set_Uses_Sec_Stack
(Trans_Id
);
4926 -- Find the construct that must be serviced by a new transient scope, if
4929 Context
:= Find_Transient_Context
(N
);
4931 if Present
(Context
) then
4932 if Nkind
(Context
) = N_Assignment_Statement
then
4934 -- An assignment statement with suppressed controlled semantics
4935 -- does not need a transient scope because finalization is not
4936 -- desirable at this point. Note that No_Ctrl_Actions is also
4937 -- set for non-controlled assignments to suppress dispatching
4940 if No_Ctrl_Actions
(Context
)
4941 and then Needs_Finalization
(Etype
(Name
(Context
)))
4943 -- When a controlled component is initialized by a function
4944 -- call, the result on the secondary stack is always assigned
4945 -- to the component. Signal the nearest suitable scope that it
4946 -- is safe to manage the secondary stack.
4948 if Manage_Sec_Stack
and then Within_Init_Proc
then
4949 Delegate_Sec_Stack_Management
;
4952 -- Otherwise the assignment is a normal transient context and thus
4953 -- requires a transient scope.
4956 Create_Transient_Scope
(Context
);
4962 Create_Transient_Scope
(Context
);
4965 end Establish_Transient_Scope
;
4967 ----------------------------
4968 -- Expand_Cleanup_Actions --
4969 ----------------------------
4971 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4973 (Nkind
(N
) in N_Block_Statement
4977 | N_Extended_Return_Statement
);
4979 Scop
: constant Entity_Id
:= Current_Scope
;
4981 Is_Asynchronous_Call
: constant Boolean :=
4982 Nkind
(N
) = N_Block_Statement
4983 and then Is_Asynchronous_Call_Block
(N
);
4984 Is_Master
: constant Boolean :=
4985 Nkind
(N
) /= N_Extended_Return_Statement
4986 and then Nkind
(N
) /= N_Entry_Body
4987 and then Is_Task_Master
(N
);
4988 Is_Protected_Subp_Body
: constant Boolean :=
4989 Nkind
(N
) = N_Subprogram_Body
4990 and then Is_Protected_Subprogram_Body
(N
);
4991 Is_Task_Allocation
: constant Boolean :=
4992 Nkind
(N
) = N_Block_Statement
4993 and then Is_Task_Allocation_Block
(N
);
4994 Is_Task_Body
: constant Boolean :=
4995 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4997 -- We mark the secondary stack if it is used in this construct, and
4998 -- we're not returning a function result on the secondary stack, except
4999 -- that a build-in-place function that might or might not return on the
5000 -- secondary stack always needs a mark. A run-time test is required in
5001 -- the case where the build-in-place function has a BIP_Alloc extra
5002 -- parameter (see Create_Finalizer).
5004 Needs_Sec_Stack_Mark
: constant Boolean :=
5005 (Uses_Sec_Stack
(Scop
)
5007 not Sec_Stack_Needed_For_Return
(Scop
))
5009 (Is_Build_In_Place_Function
(Scop
)
5010 and then Needs_BIP_Alloc_Form
(Scop
));
5012 Needs_Custom_Cleanup
: constant Boolean :=
5013 Nkind
(N
) = N_Block_Statement
5014 and then Present
(Cleanup_Actions
(N
));
5016 Actions_Required
: constant Boolean :=
5017 Requires_Cleanup_Actions
(N
, True)
5018 or else Is_Asynchronous_Call
5020 or else Is_Protected_Subp_Body
5021 or else Is_Task_Allocation
5022 or else Is_Task_Body
5023 or else Needs_Sec_Stack_Mark
5024 or else Needs_Custom_Cleanup
;
5029 -- Start of processing for Expand_Cleanup_Actions
5032 -- The current construct does not need any form of servicing
5034 if not Actions_Required
then
5037 -- If the current node is a rewritten task body and the descriptors have
5038 -- not been delayed (due to some nested instantiations), do not generate
5039 -- redundant cleanup actions.
5042 and then Nkind
(N
) = N_Subprogram_Body
5043 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
5048 -- If an extended return statement contains something like
5052 -- where F is a build-in-place function call returning a controlled
5053 -- type, then a temporary object will be implicitly declared as part
5054 -- of the statement list, and this will need cleanup. In such cases,
5057 -- return Result : T := ... do
5058 -- <statements> -- possibly with handlers
5063 -- return Result : T := ... do
5064 -- declare -- no declarations
5066 -- <statements> -- possibly with handlers
5067 -- end; -- no handlers
5070 -- So Expand_Cleanup_Actions will end up being called recursively on the
5073 if Nkind
(N
) = N_Extended_Return_Statement
then
5075 Block
: constant Node_Id
:=
5076 Make_Block_Statement
(Sloc
(N
),
5077 Declarations
=> Empty_List
,
5078 Handled_Statement_Sequence
=>
5079 Handled_Statement_Sequence
(N
));
5081 Set_Handled_Statement_Sequence
(N
,
5082 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
5083 Statements
=> New_List
(Block
)));
5088 -- Analysis of the block did all the work
5093 if Needs_Custom_Cleanup
then
5094 Cln
:= Cleanup_Actions
(N
);
5099 if No
(Declarations
(N
)) then
5100 Set_Declarations
(N
, New_List
);
5104 Decls
: constant List_Id
:= Declarations
(N
);
5106 Mark
: Entity_Id
:= Empty
;
5108 -- If we are generating expanded code for debugging purposes, use the
5109 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5110 -- be updated subsequently to reference the proper line in .dg files.
5111 -- If we are not debugging generated code, use No_Location instead,
5112 -- so that no debug information is generated for the cleanup code.
5113 -- This makes the behavior of the NEXT command in GDB monotonic, and
5114 -- makes the placement of breakpoints more accurate.
5116 if Debug_Generated_Code
then
5122 -- A task activation call has already been built for a task
5123 -- allocation block.
5125 if not Is_Task_Allocation
then
5126 Build_Task_Activation_Call
(N
);
5130 Establish_Task_Master
(N
);
5133 -- If secondary stack is in use, generate:
5135 -- Mnn : constant Mark_Id := SS_Mark;
5137 if Needs_Sec_Stack_Mark
then
5138 Set_Uses_Sec_Stack
(Scop
, False); -- avoid duplicate SS marks
5139 Mark
:= Make_Temporary
(Loc
, 'M');
5142 Mark_Call
: constant Node_Id
:= Build_SS_Mark_Call
(Loc
, Mark
);
5144 Prepend_To
(Decls
, Mark_Call
);
5145 Analyze
(Mark_Call
);
5149 -- Generate finalization calls for all controlled objects appearing
5150 -- in the statements of N. Add context specific cleanup for various
5155 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5158 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5162 if Present
(Fin_Id
) then
5163 Build_Finalizer_Call
(N
, Fin_Id
);
5166 end Expand_Cleanup_Actions
;
5168 ---------------------------
5169 -- Expand_N_Package_Body --
5170 ---------------------------
5172 -- Add call to Activate_Tasks if body is an activator (actual processing
5173 -- is in chapter 9).
5175 -- Generate subprogram descriptor for elaboration routine
5177 -- Encode entity names in package body
5179 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5180 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5184 -- This is done only for non-generic packages
5186 if Ekind
(Spec_Id
) = E_Package
then
5187 -- Build dispatch tables of library-level tagged types for bodies
5188 -- that are not compilation units (see Analyze_Compilation_Unit),
5189 -- except for instances because they have no N_Compilation_Unit.
5191 if Tagged_Type_Expansion
5192 and then Is_Library_Level_Entity
(Spec_Id
)
5193 and then (not Is_Compilation_Unit
(Spec_Id
)
5194 or else Is_Generic_Instance
(Spec_Id
))
5196 Build_Static_Dispatch_Tables
(N
);
5199 Push_Scope
(Spec_Id
);
5201 Expand_CUDA_Package
(N
);
5203 Build_Task_Activation_Call
(N
);
5205 -- Verify the run-time semantics of pragma Initial_Condition at the
5206 -- end of the body statements.
5208 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5210 -- If this is a library-level package and unnesting is enabled,
5211 -- check for the presence of blocks with nested subprograms occurring
5212 -- in elaboration code, and generate procedures to encapsulate the
5213 -- blocks in case the nested subprograms make up-level references.
5215 if Unnest_Subprogram_Mode
5217 Is_Library_Level_Entity
(Current_Scope
)
5219 Check_Unnesting_Elaboration_Code
(N
);
5220 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5221 Check_Unnesting_In_Handlers
(N
);
5227 Set_Elaboration_Flag
(N
, Spec_Id
);
5228 Set_In_Package_Body
(Spec_Id
, False);
5230 -- Set to encode entity names in package body before gigi is called
5232 Qualify_Entity_Names
(N
);
5234 if Ekind
(Spec_Id
) /= E_Generic_Package
then
5237 Clean_Stmts
=> No_List
,
5239 Top_Decls
=> No_List
,
5240 Defer_Abort
=> False,
5243 if Present
(Fin_Id
) then
5245 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
5248 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
5249 Body_Ent
:= Defining_Identifier
(Body_Ent
);
5252 Set_Finalizer
(Body_Ent
, Fin_Id
);
5256 end Expand_N_Package_Body
;
5258 ----------------------------------
5259 -- Expand_N_Package_Declaration --
5260 ----------------------------------
5262 -- Add call to Activate_Tasks if there are tasks declared and the package
5263 -- has no body. Note that in Ada 83 this may result in premature activation
5264 -- of some tasks, given that we cannot tell whether a body will eventually
5267 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5268 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5269 Spec
: constant Node_Id
:= Specification
(N
);
5273 No_Body
: Boolean := False;
5274 -- True in the case of a package declaration that is a compilation
5275 -- unit and for which no associated body will be compiled in this
5279 -- Case of a package declaration other than a compilation unit
5281 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5284 -- Case of a compilation unit that does not require a body
5286 elsif not Body_Required
(Parent
(N
))
5287 and then not Unit_Requires_Body
(Id
)
5291 -- Special case of generating calling stubs for a remote call interface
5292 -- package: even though the package declaration requires one, the body
5293 -- won't be processed in this compilation (so any stubs for RACWs
5294 -- declared in the package must be generated here, along with the spec).
5296 elsif Parent
(N
) = Cunit
(Main_Unit
)
5297 and then Is_Remote_Call_Interface
(Id
)
5298 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5303 -- For a nested instance, delay processing until freeze point
5305 if Has_Delayed_Freeze
(Id
)
5306 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5311 -- For a package declaration that implies no associated body, generate
5312 -- task activation call and RACW supporting bodies now (since we won't
5313 -- have a specific separate compilation unit for that).
5318 -- Generate RACW subprogram bodies
5320 if Has_RACW
(Id
) then
5321 Decls
:= Private_Declarations
(Spec
);
5324 Decls
:= Visible_Declarations
(Spec
);
5329 Set_Visible_Declarations
(Spec
, Decls
);
5332 Append_RACW_Bodies
(Decls
, Id
);
5333 Analyze_List
(Decls
);
5336 -- Generate task activation call as last step of elaboration
5338 if Present
(Activation_Chain_Entity
(N
)) then
5339 Build_Task_Activation_Call
(N
);
5342 -- Verify the run-time semantics of pragma Initial_Condition at the
5343 -- end of the private declarations when the package lacks a body.
5345 Expand_Pragma_Initial_Condition
(Id
, N
);
5350 -- Build dispatch tables of library-level tagged types for instances
5351 -- that are not compilation units (see Analyze_Compilation_Unit).
5353 if Tagged_Type_Expansion
5354 and then Is_Library_Level_Entity
(Id
)
5355 and then Is_Generic_Instance
(Id
)
5356 and then not Is_Compilation_Unit
(Id
)
5358 Build_Static_Dispatch_Tables
(N
);
5361 -- Note: it is not necessary to worry about generating a subprogram
5362 -- descriptor, since the only way to get exception handlers into a
5363 -- package spec is to include instantiations, and that would cause
5364 -- generation of subprogram descriptors to be delayed in any case.
5366 -- Set to encode entity names in package spec before gigi is called
5368 Qualify_Entity_Names
(N
);
5370 if Ekind
(Id
) /= E_Generic_Package
then
5373 Clean_Stmts
=> No_List
,
5375 Top_Decls
=> No_List
,
5376 Defer_Abort
=> False,
5379 Set_Finalizer
(Id
, Fin_Id
);
5382 -- If this is a library-level package and unnesting is enabled,
5383 -- check for the presence of blocks with nested subprograms occurring
5384 -- in elaboration code, and generate procedures to encapsulate the
5385 -- blocks in case the nested subprograms make up-level references.
5387 if Unnest_Subprogram_Mode
5388 and then Is_Library_Level_Entity
(Current_Scope
)
5390 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
5391 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
5393 end Expand_N_Package_Declaration
;
5395 ---------------------------------
5396 -- Has_Simple_Protected_Object --
5397 ---------------------------------
5399 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5401 if Has_Task
(T
) then
5404 elsif Is_Simple_Protected_Type
(T
) then
5407 elsif Is_Array_Type
(T
) then
5408 return Has_Simple_Protected_Object
(Component_Type
(T
));
5410 elsif Is_Record_Type
(T
) then
5415 Comp
:= First_Component
(T
);
5416 while Present
(Comp
) loop
5417 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5421 Next_Component
(Comp
);
5430 end Has_Simple_Protected_Object
;
5432 ------------------------------------
5433 -- Insert_Actions_In_Scope_Around --
5434 ------------------------------------
5436 procedure Insert_Actions_In_Scope_Around
5439 Manage_SS
: Boolean)
5441 Act_Before
: constant List_Id
:=
5442 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5443 Act_After
: constant List_Id
:=
5444 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5445 Act_Cleanup
: constant List_Id
:=
5446 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5447 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5448 -- Last), but this was incorrect as Process_Transients_In_Scope may
5449 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5451 procedure Process_Transients_In_Scope
5452 (First_Object
: Node_Id
;
5453 Last_Object
: Node_Id
;
5454 Related_Node
: Node_Id
);
5455 -- Find all transient objects in the list First_Object .. Last_Object
5456 -- and generate finalization actions for them. Related_Node denotes the
5457 -- node which created all transient objects.
5459 ---------------------------------
5460 -- Process_Transients_In_Scope --
5461 ---------------------------------
5463 procedure Process_Transients_In_Scope
5464 (First_Object
: Node_Id
;
5465 Last_Object
: Node_Id
;
5466 Related_Node
: Node_Id
)
5468 Must_Hook
: Boolean;
5469 -- Flag denoting whether the context requires transient object
5470 -- export to the outer finalizer.
5472 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5473 -- Return Abandon if arbitrary node denotes a subprogram call
5475 function Has_Subprogram_Call
is
5476 new Traverse_Func
(Is_Subprogram_Call
);
5478 procedure Process_Transient_In_Scope
5479 (Obj_Decl
: Node_Id
;
5480 Blk_Data
: Finalization_Exception_Data
;
5481 Blk_Stmts
: List_Id
);
5482 -- Generate finalization actions for a single transient object
5483 -- denoted by object declaration Obj_Decl. Blk_Data is the
5484 -- exception data of the enclosing block. Blk_Stmts denotes the
5485 -- statements of the enclosing block.
5487 ------------------------
5488 -- Is_Subprogram_Call --
5489 ------------------------
5491 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5493 -- A regular procedure or function call
5495 if Nkind
(N
) in N_Subprogram_Call
then
5500 -- Heavy expansion may relocate function calls outside the related
5501 -- node. Inspect the original node to detect the initial placement
5504 elsif Is_Rewrite_Substitution
(N
) then
5505 return Has_Subprogram_Call
(Original_Node
(N
));
5507 -- Generalized indexing always involves a function call
5509 elsif Nkind
(N
) = N_Indexed_Component
5510 and then Present
(Generalized_Indexing
(N
))
5519 end Is_Subprogram_Call
;
5521 --------------------------------
5522 -- Process_Transient_In_Scope --
5523 --------------------------------
5525 procedure Process_Transient_In_Scope
5526 (Obj_Decl
: Node_Id
;
5527 Blk_Data
: Finalization_Exception_Data
;
5528 Blk_Stmts
: List_Id
)
5530 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5531 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5533 Fin_Stmts
: List_Id
;
5534 Hook_Assign
: Node_Id
;
5535 Hook_Clear
: Node_Id
;
5536 Hook_Decl
: Node_Id
;
5537 Hook_Insert
: Node_Id
;
5541 -- Mark the transient object as successfully processed to avoid
5542 -- double finalization.
5544 Set_Is_Finalized_Transient
(Obj_Id
);
5546 -- Construct all the pieces necessary to hook and finalize the
5547 -- transient object.
5549 Build_Transient_Object_Statements
5550 (Obj_Decl
=> Obj_Decl
,
5551 Fin_Call
=> Fin_Call
,
5552 Hook_Assign
=> Hook_Assign
,
5553 Hook_Clear
=> Hook_Clear
,
5554 Hook_Decl
=> Hook_Decl
,
5555 Ptr_Decl
=> Ptr_Decl
);
5557 -- The context contains at least one subprogram call which may
5558 -- raise an exception. This scenario employs "hooking" to pass
5559 -- transient objects to the enclosing finalizer in case of an
5564 -- Add the access type which provides a reference to the
5565 -- transient object. Generate:
5567 -- type Ptr_Typ is access all Desig_Typ;
5569 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5571 -- Add the temporary which acts as a hook to the transient
5572 -- object. Generate:
5574 -- Hook : Ptr_Typ := null;
5576 Insert_Action
(Obj_Decl
, Hook_Decl
);
5578 -- When the transient object is initialized by an aggregate,
5579 -- the hook must capture the object after the last aggregate
5580 -- assignment takes place. Only then is the object considered
5581 -- fully initialized. Generate:
5583 -- Hook := Ptr_Typ (Obj_Id);
5585 -- Hook := Obj_Id'Unrestricted_Access;
5587 -- Similarly if we have a build in place call: we must
5588 -- initialize Hook only after the call has happened, otherwise
5589 -- Obj_Id will not be initialized yet.
5591 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
5592 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
5593 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5594 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
5595 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
5597 Hook_Insert
:= Obj_Decl
;
5600 -- Otherwise the hook seizes the related object immediately
5603 Hook_Insert
:= Obj_Decl
;
5606 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5609 -- When exception propagation is enabled wrap the hook clear
5610 -- statement and the finalization call into a block to catch
5611 -- potential exceptions raised during finalization. Generate:
5615 -- [Deep_]Finalize (Obj_Ref);
5619 -- if not Raised then
5622 -- (Enn, Get_Current_Excep.all.all);
5626 if Exceptions_OK
then
5627 Fin_Stmts
:= New_List
;
5630 Append_To
(Fin_Stmts
, Hook_Clear
);
5633 Append_To
(Fin_Stmts
, Fin_Call
);
5635 Prepend_To
(Blk_Stmts
,
5636 Make_Block_Statement
(Loc
,
5637 Handled_Statement_Sequence
=>
5638 Make_Handled_Sequence_Of_Statements
(Loc
,
5639 Statements
=> Fin_Stmts
,
5640 Exception_Handlers
=> New_List
(
5641 Build_Exception_Handler
(Blk_Data
)))));
5643 -- Otherwise generate:
5646 -- [Deep_]Finalize (Obj_Ref);
5648 -- Note that the statements are inserted in reverse order to
5649 -- achieve the desired final order outlined above.
5652 Prepend_To
(Blk_Stmts
, Fin_Call
);
5655 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5658 end Process_Transient_In_Scope
;
5662 Built
: Boolean := False;
5663 Blk_Data
: Finalization_Exception_Data
;
5664 Blk_Decl
: Node_Id
:= Empty
;
5665 Blk_Decls
: List_Id
:= No_List
;
5667 Blk_Stmts
: List_Id
:= No_List
;
5668 Loc
: Source_Ptr
:= No_Location
;
5671 -- Start of processing for Process_Transients_In_Scope
5674 -- The expansion performed by this routine is as follows:
5676 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5677 -- Hook_1 : Ptr_Typ_1 := null;
5678 -- Ctrl_Trans_Obj_1 : ...;
5679 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5681 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5682 -- Hook_N : Ptr_Typ_N := null;
5683 -- Ctrl_Trans_Obj_N : ...;
5684 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5687 -- Abrt : constant Boolean := ...;
5688 -- Ex : Exception_Occurrence;
5689 -- Raised : Boolean := False;
5696 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5700 -- if not Raised then
5702 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5707 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5711 -- if not Raised then
5713 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5718 -- if Raised and not Abrt then
5719 -- Raise_From_Controlled_Operation (Ex);
5723 -- Recognize a scenario where the transient context is an object
5724 -- declaration initialized by a build-in-place function call:
5726 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5728 -- The rough expansion of the above is:
5730 -- Temp : ... := Ctrl_Func_Call;
5732 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5734 -- The finalization of any transient object must happen after the
5735 -- build-in-place function call is executed.
5737 if Nkind
(N
) = N_Object_Declaration
5738 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5741 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5743 -- Search the context for at least one subprogram call. If found, the
5744 -- machinery exports all transient objects to the enclosing finalizer
5745 -- due to the possibility of abnormal call termination.
5748 Must_Hook
:= Has_Subprogram_Call
(N
) = Abandon
;
5749 Blk_Ins
:= Last_Object
;
5753 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5756 -- Examine all objects in the list First_Object .. Last_Object
5758 Obj_Decl
:= First_Object
;
5759 while Present
(Obj_Decl
) loop
5760 if Nkind
(Obj_Decl
) = N_Object_Declaration
5761 and then Analyzed
(Obj_Decl
)
5762 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5764 -- Do not process the node to be wrapped since it will be
5765 -- handled by the enclosing finalizer.
5767 and then Obj_Decl
/= Related_Node
5769 Loc
:= Sloc
(Obj_Decl
);
5771 -- Before generating the cleanup code for the first transient
5772 -- object, create a wrapper block which houses all hook clear
5773 -- statements and finalization calls. This wrapper is needed by
5778 Blk_Stmts
:= New_List
;
5781 -- Abrt : constant Boolean := ...;
5782 -- Ex : Exception_Occurrence;
5783 -- Raised : Boolean := False;
5785 if Exceptions_OK
then
5786 Blk_Decls
:= New_List
;
5787 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5791 Make_Block_Statement
(Loc
,
5792 Declarations
=> Blk_Decls
,
5793 Handled_Statement_Sequence
=>
5794 Make_Handled_Sequence_Of_Statements
(Loc
,
5795 Statements
=> Blk_Stmts
));
5798 -- Construct all necessary circuitry to hook and finalize a
5799 -- single transient object.
5801 pragma Assert
(Present
(Blk_Stmts
));
5802 Process_Transient_In_Scope
5803 (Obj_Decl
=> Obj_Decl
,
5804 Blk_Data
=> Blk_Data
,
5805 Blk_Stmts
=> Blk_Stmts
);
5808 -- Terminate the scan after the last object has been processed to
5809 -- avoid touching unrelated code.
5811 if Obj_Decl
= Last_Object
then
5818 -- Complete the decoration of the enclosing finalization block and
5819 -- insert it into the tree.
5821 if Present
(Blk_Decl
) then
5823 pragma Assert
(Present
(Blk_Stmts
));
5824 pragma Assert
(Loc
/= No_Location
);
5826 -- Note that this Abort_Undefer does not require a extra block or
5827 -- an AT_END handler because each finalization exception is caught
5828 -- in its own corresponding finalization block. As a result, the
5829 -- call to Abort_Defer always takes place.
5831 if Abort_Allowed
then
5832 Prepend_To
(Blk_Stmts
,
5833 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5835 Append_To
(Blk_Stmts
,
5836 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5840 -- if Raised and then not Abrt then
5841 -- Raise_From_Controlled_Operation (Ex);
5844 if Exceptions_OK
then
5845 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5848 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5850 end Process_Transients_In_Scope
;
5854 Loc
: constant Source_Ptr
:= Sloc
(N
);
5855 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5856 First_Obj
: Node_Id
;
5858 Mark_Id
: Entity_Id
;
5861 -- Start of processing for Insert_Actions_In_Scope_Around
5864 -- Nothing to do if the scope does not manage the secondary stack or
5865 -- does not contain meaningful actions for insertion.
5868 and then No
(Act_Before
)
5869 and then No
(Act_After
)
5870 and then No
(Act_Cleanup
)
5875 -- If the node to be wrapped is the trigger of an asynchronous select,
5876 -- it is not part of a statement list. The actions must be inserted
5877 -- before the select itself, which is part of some list of statements.
5878 -- Note that the triggering alternative includes the triggering
5879 -- statement and an optional statement list. If the node to be
5880 -- wrapped is part of that list, the normal insertion applies.
5882 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5883 and then not Is_List_Member
(Node_To_Wrap
)
5885 Target
:= Parent
(Parent
(Node_To_Wrap
));
5890 First_Obj
:= Target
;
5893 -- Add all actions associated with a transient scope into the main tree.
5894 -- There are several scenarios here:
5896 -- +--- Before ----+ +----- After ---+
5897 -- 1) First_Obj ....... Target ........ Last_Obj
5899 -- 2) First_Obj ....... Target
5901 -- 3) Target ........ Last_Obj
5903 -- Flag declarations are inserted before the first object
5905 if Present
(Act_Before
) then
5906 First_Obj
:= First
(Act_Before
);
5907 Insert_List_Before
(Target
, Act_Before
);
5910 -- Finalization calls are inserted after the last object
5912 if Present
(Act_After
) then
5913 Last_Obj
:= Last
(Act_After
);
5914 Insert_List_After
(Target
, Act_After
);
5917 -- Mark and release the secondary stack when the context warrants it
5920 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5923 -- Mnn : constant Mark_Id := SS_Mark;
5925 Insert_Before_And_Analyze
5926 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5929 -- SS_Release (Mnn);
5931 Insert_After_And_Analyze
5932 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5935 -- Check for transient objects associated with Target and generate the
5936 -- appropriate finalization actions for them.
5938 Process_Transients_In_Scope
5939 (First_Object
=> First_Obj
,
5940 Last_Object
=> Last_Obj
,
5941 Related_Node
=> Target
);
5943 -- Reset the action lists
5946 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5948 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5952 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5954 end Insert_Actions_In_Scope_Around
;
5956 ------------------------------
5957 -- Is_Simple_Protected_Type --
5958 ------------------------------
5960 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5963 Is_Protected_Type
(T
)
5964 and then not Uses_Lock_Free
(T
)
5965 and then not Has_Entries
(T
)
5966 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5967 end Is_Simple_Protected_Type
;
5969 -----------------------
5970 -- Make_Adjust_Call --
5971 -----------------------
5973 function Make_Adjust_Call
5976 Skip_Self
: Boolean := False) return Node_Id
5978 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5979 Adj_Id
: Entity_Id
:= Empty
;
5986 -- Recover the proper type which contains Deep_Adjust
5988 if Is_Class_Wide_Type
(Typ
) then
5989 Utyp
:= Root_Type
(Typ
);
5994 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5995 Set_Assignment_OK
(Ref
);
5997 -- Deal with untagged derivation of private views
5999 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
6000 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
6001 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6002 Set_Assignment_OK
(Ref
);
6005 -- When dealing with the completion of a private type, use the base
6008 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
6009 pragma Assert
(Is_Private_Type
(Typ
));
6011 Utyp
:= Base_Type
(Utyp
);
6012 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
6015 -- The underlying type may not be present due to a missing full view. In
6016 -- this case freezing did not take place and there is no [Deep_]Adjust
6017 -- primitive to call.
6022 elsif Skip_Self
then
6023 if Has_Controlled_Component
(Utyp
) then
6024 if Is_Tagged_Type
(Utyp
) then
6025 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6027 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6031 -- Class-wide types, interfaces and types with controlled components
6033 elsif Is_Class_Wide_Type
(Typ
)
6034 or else Is_Interface
(Typ
)
6035 or else Has_Controlled_Component
(Utyp
)
6037 if Is_Tagged_Type
(Utyp
) then
6038 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6040 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
6043 -- Derivations from [Limited_]Controlled
6045 elsif Is_Controlled
(Utyp
) then
6046 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
6050 elsif Is_Tagged_Type
(Utyp
) then
6051 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
6054 raise Program_Error
;
6057 if Present
(Adj_Id
) then
6059 -- If the object is unanalyzed, set its expected type for use in
6060 -- Convert_View in case an additional conversion is needed.
6063 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
6065 Set_Etype
(Ref
, Typ
);
6068 -- The object reference may need another conversion depending on the
6069 -- type of the formal and that of the actual.
6071 if not Is_Class_Wide_Type
(Typ
) then
6072 Ref
:= Convert_View
(Adj_Id
, Ref
);
6079 Skip_Self
=> Skip_Self
);
6083 end Make_Adjust_Call
;
6091 Proc_Id
: Entity_Id
;
6093 Skip_Self
: Boolean := False) return Node_Id
6095 Params
: constant List_Id
:= New_List
(Param
);
6098 -- Do not apply the controlled action to the object itself by signaling
6099 -- the related routine to avoid self.
6102 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6106 Make_Procedure_Call_Statement
(Loc
,
6107 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6108 Parameter_Associations
=> Params
);
6111 --------------------------
6112 -- Make_Deep_Array_Body --
6113 --------------------------
6115 function Make_Deep_Array_Body
6116 (Prim
: Final_Primitives
;
6117 Typ
: Entity_Id
) return List_Id
6119 function Build_Adjust_Or_Finalize_Statements
6120 (Typ
: Entity_Id
) return List_Id
;
6121 -- Create the statements necessary to adjust or finalize an array of
6122 -- controlled elements. Generate:
6125 -- Abort : constant Boolean := Triggered_By_Abort;
6127 -- Abort : constant Boolean := False; -- no abort
6129 -- E : Exception_Occurrence;
6130 -- Raised : Boolean := False;
6133 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6134 -- ^-- in the finalization case
6136 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6138 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6142 -- if not Raised then
6144 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6151 -- if Raised and then not Abort then
6152 -- Raise_From_Controlled_Operation (E);
6156 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6157 -- Create the statements necessary to initialize an array of controlled
6158 -- elements. Include a mechanism to carry out partial finalization if an
6159 -- exception occurs. Generate:
6162 -- Counter : Integer := 0;
6165 -- for J1 in V'Range (1) loop
6167 -- for JN in V'Range (N) loop
6169 -- [Deep_]Initialize (V (J1, ..., JN));
6171 -- Counter := Counter + 1;
6176 -- Abort : constant Boolean := Triggered_By_Abort;
6178 -- Abort : constant Boolean := False; -- no abort
6179 -- E : Exception_Occurrence;
6180 -- Raised : Boolean := False;
6187 -- V'Length (N) - Counter;
6189 -- for F1 in reverse V'Range (1) loop
6191 -- for FN in reverse V'Range (N) loop
6192 -- if Counter > 0 then
6193 -- Counter := Counter - 1;
6196 -- [Deep_]Finalize (V (F1, ..., FN));
6200 -- if not Raised then
6202 -- Save_Occurrence (E,
6203 -- Get_Current_Excep.all.all);
6212 -- if Raised and then not Abort then
6213 -- Raise_From_Controlled_Operation (E);
6222 function New_References_To
6224 Loc
: Source_Ptr
) return List_Id
;
6225 -- Given a list of defining identifiers, return a list of references to
6226 -- the original identifiers, in the same order as they appear.
6228 -----------------------------------------
6229 -- Build_Adjust_Or_Finalize_Statements --
6230 -----------------------------------------
6232 function Build_Adjust_Or_Finalize_Statements
6233 (Typ
: Entity_Id
) return List_Id
6235 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6236 Index_List
: constant List_Id
:= New_List
;
6237 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6238 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6240 procedure Build_Indexes
;
6241 -- Generate the indexes used in the dimension loops
6247 procedure Build_Indexes
is
6249 -- Generate the following identifiers:
6250 -- Jnn - for initialization
6252 for Dim
in 1 .. Num_Dims
loop
6253 Append_To
(Index_List
,
6254 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6260 Final_Decls
: List_Id
:= No_List
;
6261 Final_Data
: Finalization_Exception_Data
;
6265 Core_Loop
: Node_Id
;
6268 Loop_Id
: Entity_Id
;
6271 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6274 Final_Decls
:= New_List
;
6277 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6280 Make_Indexed_Component
(Loc
,
6281 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6282 Expressions
=> New_References_To
(Index_List
, Loc
));
6283 Set_Etype
(Comp_Ref
, Comp_Typ
);
6286 -- [Deep_]Adjust (V (J1, ..., JN))
6288 if Prim
= Adjust_Case
then
6289 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6292 -- [Deep_]Finalize (V (J1, ..., JN))
6294 else pragma Assert
(Prim
= Finalize_Case
);
6295 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6298 if Present
(Call
) then
6300 -- Generate the block which houses the adjust or finalize call:
6303 -- <adjust or finalize call>
6307 -- if not Raised then
6309 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6313 if Exceptions_OK
then
6315 Make_Block_Statement
(Loc
,
6316 Handled_Statement_Sequence
=>
6317 Make_Handled_Sequence_Of_Statements
(Loc
,
6318 Statements
=> New_List
(Call
),
6319 Exception_Handlers
=> New_List
(
6320 Build_Exception_Handler
(Final_Data
))));
6325 -- Generate the dimension loops starting from the innermost one
6327 -- for Jnn in [reverse] V'Range (Dim) loop
6331 J
:= Last
(Index_List
);
6333 while Present
(J
) and then Dim
> 0 loop
6339 Make_Loop_Statement
(Loc
,
6341 Make_Iteration_Scheme
(Loc
,
6342 Loop_Parameter_Specification
=>
6343 Make_Loop_Parameter_Specification
(Loc
,
6344 Defining_Identifier
=> Loop_Id
,
6345 Discrete_Subtype_Definition
=>
6346 Make_Attribute_Reference
(Loc
,
6347 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6348 Attribute_Name
=> Name_Range
,
6349 Expressions
=> New_List
(
6350 Make_Integer_Literal
(Loc
, Dim
))),
6353 Prim
= Finalize_Case
)),
6355 Statements
=> New_List
(Core_Loop
),
6356 End_Label
=> Empty
);
6361 -- Generate the block which contains the core loop, declarations
6362 -- of the abort flag, the exception occurrence, the raised flag
6363 -- and the conditional raise:
6366 -- Abort : constant Boolean := Triggered_By_Abort;
6368 -- Abort : constant Boolean := False; -- no abort
6370 -- E : Exception_Occurrence;
6371 -- Raised : Boolean := False;
6376 -- if Raised and then not Abort then
6377 -- Raise_From_Controlled_Operation (E);
6381 Stmts
:= New_List
(Core_Loop
);
6383 if Exceptions_OK
then
6384 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6388 Make_Block_Statement
(Loc
,
6389 Declarations
=> Final_Decls
,
6390 Handled_Statement_Sequence
=>
6391 Make_Handled_Sequence_Of_Statements
(Loc
,
6392 Statements
=> Stmts
));
6394 -- Otherwise previous errors or a missing full view may prevent the
6395 -- proper freezing of the component type. If this is the case, there
6396 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6399 Block
:= Make_Null_Statement
(Loc
);
6402 return New_List
(Block
);
6403 end Build_Adjust_Or_Finalize_Statements
;
6405 ---------------------------------
6406 -- Build_Initialize_Statements --
6407 ---------------------------------
6409 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6410 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6411 Final_List
: constant List_Id
:= New_List
;
6412 Index_List
: constant List_Id
:= New_List
;
6413 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6414 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6416 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6417 -- Generate the following assignment:
6418 -- Counter := V'Length (1) *
6420 -- V'Length (N) - Counter;
6422 -- Counter_Id denotes the entity of the counter.
6424 function Build_Finalization_Call
return Node_Id
;
6425 -- Generate a deep finalization call for an array element
6427 procedure Build_Indexes
;
6428 -- Generate the initialization and finalization indexes used in the
6431 function Build_Initialization_Call
return Node_Id
;
6432 -- Generate a deep initialization call for an array element
6434 ----------------------
6435 -- Build_Assignment --
6436 ----------------------
6438 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6443 -- Start from the first dimension and generate:
6448 Make_Attribute_Reference
(Loc
,
6449 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6450 Attribute_Name
=> Name_Length
,
6451 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6453 -- Process the rest of the dimensions, generate:
6454 -- Expr * V'Length (N)
6457 while Dim
<= Num_Dims
loop
6459 Make_Op_Multiply
(Loc
,
6462 Make_Attribute_Reference
(Loc
,
6463 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6464 Attribute_Name
=> Name_Length
,
6465 Expressions
=> New_List
(
6466 Make_Integer_Literal
(Loc
, Dim
))));
6472 -- Counter := Expr - Counter;
6475 Make_Assignment_Statement
(Loc
,
6476 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6478 Make_Op_Subtract
(Loc
,
6480 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6481 end Build_Assignment
;
6483 -----------------------------
6484 -- Build_Finalization_Call --
6485 -----------------------------
6487 function Build_Finalization_Call
return Node_Id
is
6488 Comp_Ref
: constant Node_Id
:=
6489 Make_Indexed_Component
(Loc
,
6490 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6491 Expressions
=> New_References_To
(Final_List
, Loc
));
6494 Set_Etype
(Comp_Ref
, Comp_Typ
);
6497 -- [Deep_]Finalize (V);
6499 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6500 end Build_Finalization_Call
;
6506 procedure Build_Indexes
is
6508 -- Generate the following identifiers:
6509 -- Jnn - for initialization
6510 -- Fnn - for finalization
6512 for Dim
in 1 .. Num_Dims
loop
6513 Append_To
(Index_List
,
6514 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6516 Append_To
(Final_List
,
6517 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6521 -------------------------------
6522 -- Build_Initialization_Call --
6523 -------------------------------
6525 function Build_Initialization_Call
return Node_Id
is
6526 Comp_Ref
: constant Node_Id
:=
6527 Make_Indexed_Component
(Loc
,
6528 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6529 Expressions
=> New_References_To
(Index_List
, Loc
));
6532 Set_Etype
(Comp_Ref
, Comp_Typ
);
6535 -- [Deep_]Initialize (V (J1, ..., JN));
6537 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6538 end Build_Initialization_Call
;
6542 Counter_Id
: Entity_Id
;
6546 Final_Block
: Node_Id
;
6547 Final_Data
: Finalization_Exception_Data
;
6548 Final_Decls
: List_Id
:= No_List
;
6549 Final_Loop
: Node_Id
;
6550 Init_Block
: Node_Id
;
6551 Init_Call
: Node_Id
;
6552 Init_Loop
: Node_Id
;
6557 -- Start of processing for Build_Initialize_Statements
6560 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6561 Final_Decls
:= New_List
;
6564 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6566 -- Generate the block which houses the finalization call, the index
6567 -- guard and the handler which triggers Program_Error later on.
6569 -- if Counter > 0 then
6570 -- Counter := Counter - 1;
6573 -- [Deep_]Finalize (V (F1, ..., FN));
6576 -- if not Raised then
6578 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6583 Fin_Stmt
:= Build_Finalization_Call
;
6585 if Present
(Fin_Stmt
) then
6586 if Exceptions_OK
then
6588 Make_Block_Statement
(Loc
,
6589 Handled_Statement_Sequence
=>
6590 Make_Handled_Sequence_Of_Statements
(Loc
,
6591 Statements
=> New_List
(Fin_Stmt
),
6592 Exception_Handlers
=> New_List
(
6593 Build_Exception_Handler
(Final_Data
))));
6596 -- This is the core of the loop, the dimension iterators are added
6597 -- one by one in reverse.
6600 Make_If_Statement
(Loc
,
6603 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6604 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6606 Then_Statements
=> New_List
(
6607 Make_Assignment_Statement
(Loc
,
6608 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6610 Make_Op_Subtract
(Loc
,
6611 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6612 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6614 Else_Statements
=> New_List
(Fin_Stmt
));
6616 -- Generate all finalization loops starting from the innermost
6619 -- for Fnn in reverse V'Range (Dim) loop
6623 F
:= Last
(Final_List
);
6625 while Present
(F
) and then Dim
> 0 loop
6631 Make_Loop_Statement
(Loc
,
6633 Make_Iteration_Scheme
(Loc
,
6634 Loop_Parameter_Specification
=>
6635 Make_Loop_Parameter_Specification
(Loc
,
6636 Defining_Identifier
=> Loop_Id
,
6637 Discrete_Subtype_Definition
=>
6638 Make_Attribute_Reference
(Loc
,
6639 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6640 Attribute_Name
=> Name_Range
,
6641 Expressions
=> New_List
(
6642 Make_Integer_Literal
(Loc
, Dim
))),
6644 Reverse_Present
=> True)),
6646 Statements
=> New_List
(Final_Loop
),
6647 End_Label
=> Empty
);
6652 -- Generate the block which contains the finalization loops, the
6653 -- declarations of the abort flag, the exception occurrence, the
6654 -- raised flag and the conditional raise.
6657 -- Abort : constant Boolean := Triggered_By_Abort;
6659 -- Abort : constant Boolean := False; -- no abort
6661 -- E : Exception_Occurrence;
6662 -- Raised : Boolean := False;
6668 -- V'Length (N) - Counter;
6672 -- if Raised and then not Abort then
6673 -- Raise_From_Controlled_Operation (E);
6679 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6681 if Exceptions_OK
then
6682 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6683 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6687 Make_Block_Statement
(Loc
,
6688 Declarations
=> Final_Decls
,
6689 Handled_Statement_Sequence
=>
6690 Make_Handled_Sequence_Of_Statements
(Loc
,
6691 Statements
=> Stmts
));
6693 -- Otherwise previous errors or a missing full view may prevent the
6694 -- proper freezing of the component type. If this is the case, there
6695 -- is no [Deep_]Finalize primitive to call.
6698 Final_Block
:= Make_Null_Statement
(Loc
);
6701 -- Generate the block which contains the initialization call and
6702 -- the partial finalization code.
6705 -- [Deep_]Initialize (V (J1, ..., JN));
6707 -- Counter := Counter + 1;
6711 -- <finalization code>
6714 Init_Call
:= Build_Initialization_Call
;
6716 -- Only create finalization block if there is a nontrivial call
6717 -- to initialization or a Default_Initial_Condition check to be
6720 if (Present
(Init_Call
)
6721 and then Nkind
(Init_Call
) /= N_Null_Statement
)
6724 and then not GNATprove_Mode
6725 and then Present
(DIC_Procedure
(Comp_Typ
))
6726 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
6729 Init_Stmts
: constant List_Id
:= New_List
;
6732 if Present
(Init_Call
) then
6733 Append_To
(Init_Stmts
, Init_Call
);
6736 if Has_DIC
(Comp_Typ
)
6737 and then Present
(DIC_Procedure
(Comp_Typ
))
6741 Build_DIC_Call
(Loc
,
6742 Make_Indexed_Component
(Loc
,
6743 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6744 Expressions
=> New_References_To
(Index_List
, Loc
)),
6749 Make_Block_Statement
(Loc
,
6750 Handled_Statement_Sequence
=>
6751 Make_Handled_Sequence_Of_Statements
(Loc
,
6752 Statements
=> Init_Stmts
,
6753 Exception_Handlers
=> New_List
(
6754 Make_Exception_Handler
(Loc
,
6755 Exception_Choices
=> New_List
(
6756 Make_Others_Choice
(Loc
)),
6757 Statements
=> New_List
(Final_Block
)))));
6760 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6761 Make_Assignment_Statement
(Loc
,
6762 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6765 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6766 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6768 -- Generate all initialization loops starting from the innermost
6771 -- for Jnn in V'Range (Dim) loop
6775 J
:= Last
(Index_List
);
6777 while Present
(J
) and then Dim
> 0 loop
6783 Make_Loop_Statement
(Loc
,
6785 Make_Iteration_Scheme
(Loc
,
6786 Loop_Parameter_Specification
=>
6787 Make_Loop_Parameter_Specification
(Loc
,
6788 Defining_Identifier
=> Loop_Id
,
6789 Discrete_Subtype_Definition
=>
6790 Make_Attribute_Reference
(Loc
,
6791 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6792 Attribute_Name
=> Name_Range
,
6793 Expressions
=> New_List
(
6794 Make_Integer_Literal
(Loc
, Dim
))))),
6796 Statements
=> New_List
(Init_Loop
),
6797 End_Label
=> Empty
);
6802 -- Generate the block which contains the counter variable and the
6803 -- initialization loops.
6806 -- Counter : Integer := 0;
6812 Make_Block_Statement
(Loc
,
6813 Declarations
=> New_List
(
6814 Make_Object_Declaration
(Loc
,
6815 Defining_Identifier
=> Counter_Id
,
6816 Object_Definition
=>
6817 New_Occurrence_Of
(Standard_Integer
, Loc
),
6818 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6820 Handled_Statement_Sequence
=>
6821 Make_Handled_Sequence_Of_Statements
(Loc
,
6822 Statements
=> New_List
(Init_Loop
)));
6824 if Debug_Generated_Code
then
6825 Set_Debug_Info_Needed
(Counter_Id
);
6828 -- Otherwise previous errors or a missing full view may prevent the
6829 -- proper freezing of the component type. If this is the case, there
6830 -- is no [Deep_]Initialize primitive to call.
6833 Init_Block
:= Make_Null_Statement
(Loc
);
6836 return New_List
(Init_Block
);
6837 end Build_Initialize_Statements
;
6839 -----------------------
6840 -- New_References_To --
6841 -----------------------
6843 function New_References_To
6845 Loc
: Source_Ptr
) return List_Id
6847 Refs
: constant List_Id
:= New_List
;
6852 while Present
(Id
) loop
6853 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6858 end New_References_To
;
6860 -- Start of processing for Make_Deep_Array_Body
6864 when Address_Case
=>
6865 return Make_Finalize_Address_Stmts
(Typ
);
6870 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6872 when Initialize_Case
=>
6873 return Build_Initialize_Statements
(Typ
);
6875 end Make_Deep_Array_Body
;
6877 --------------------
6878 -- Make_Deep_Proc --
6879 --------------------
6881 function Make_Deep_Proc
6882 (Prim
: Final_Primitives
;
6884 Stmts
: List_Id
) return Entity_Id
6886 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6888 Proc_Id
: Entity_Id
;
6891 -- Create the object formal, generate:
6892 -- V : System.Address
6894 if Prim
= Address_Case
then
6895 Formals
:= New_List
(
6896 Make_Parameter_Specification
(Loc
,
6897 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6899 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6906 Formals
:= New_List
(
6907 Make_Parameter_Specification
(Loc
,
6908 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6910 Out_Present
=> True,
6911 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6913 -- F : Boolean := True
6915 if Prim
= Adjust_Case
6916 or else Prim
= Finalize_Case
6919 Make_Parameter_Specification
(Loc
,
6920 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6922 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6924 New_Occurrence_Of
(Standard_True
, Loc
)));
6929 Make_Defining_Identifier
(Loc
,
6930 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6933 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6936 -- exception -- Finalize and Adjust cases only
6937 -- raise Program_Error;
6938 -- end Deep_Initialize / Adjust / Finalize;
6942 -- procedure Finalize_Address (V : System.Address) is
6945 -- end Finalize_Address;
6948 Make_Subprogram_Body
(Loc
,
6950 Make_Procedure_Specification
(Loc
,
6951 Defining_Unit_Name
=> Proc_Id
,
6952 Parameter_Specifications
=> Formals
),
6954 Declarations
=> Empty_List
,
6956 Handled_Statement_Sequence
=>
6957 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6959 -- If there are no calls to component initialization, indicate that
6960 -- the procedure is trivial, so prevent calls to it.
6962 if Is_Empty_List
(Stmts
)
6963 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6965 Set_Is_Trivial_Subprogram
(Proc_Id
);
6971 ---------------------------
6972 -- Make_Deep_Record_Body --
6973 ---------------------------
6975 function Make_Deep_Record_Body
6976 (Prim
: Final_Primitives
;
6978 Is_Local
: Boolean := False) return List_Id
6980 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6981 -- Build the statements necessary to adjust a record type. The type may
6982 -- have discriminants and contain variant parts. Generate:
6986 -- [Deep_]Adjust (V.Comp_1);
6988 -- when Id : others =>
6989 -- if not Raised then
6991 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6996 -- [Deep_]Adjust (V.Comp_N);
6998 -- when Id : others =>
6999 -- if not Raised then
7001 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7006 -- Deep_Adjust (V._parent, False); -- If applicable
7008 -- when Id : others =>
7009 -- if not Raised then
7011 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7017 -- Adjust (V); -- If applicable
7020 -- if not Raised then
7022 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7027 -- if Raised and then not Abort then
7028 -- Raise_From_Controlled_Operation (E);
7032 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
7033 -- Build the statements necessary to finalize a record type. The type
7034 -- may have discriminants and contain variant parts. Generate:
7037 -- Abort : constant Boolean := Triggered_By_Abort;
7039 -- Abort : constant Boolean := False; -- no abort
7040 -- E : Exception_Occurrence;
7041 -- Raised : Boolean := False;
7046 -- Finalize (V); -- If applicable
7049 -- if not Raised then
7051 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7056 -- case Variant_1 is
7058 -- case State_Counter_N => -- If Is_Local is enabled
7068 -- <<LN>> -- If Is_Local is enabled
7070 -- [Deep_]Finalize (V.Comp_N);
7073 -- if not Raised then
7075 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7081 -- [Deep_]Finalize (V.Comp_1);
7084 -- if not Raised then
7086 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7092 -- case State_Counter_1 => -- If Is_Local is enabled
7098 -- Deep_Finalize (V._parent, False); -- If applicable
7100 -- when Id : others =>
7101 -- if not Raised then
7103 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7107 -- if Raised and then not Abort then
7108 -- Raise_From_Controlled_Operation (E);
7112 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7113 -- Given a derived tagged type Typ, traverse all components, find field
7114 -- _parent and return its type.
7116 procedure Preprocess_Components
7118 Num_Comps
: out Nat
;
7119 Has_POC
: out Boolean);
7120 -- Examine all components in component list Comps, count all controlled
7121 -- components and determine whether at least one of them is per-object
7122 -- constrained. Component _parent is always skipped.
7124 -----------------------------
7125 -- Build_Adjust_Statements --
7126 -----------------------------
7128 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7129 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7130 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7132 Finalizer_Data
: Finalization_Exception_Data
;
7134 function Process_Component_List_For_Adjust
7135 (Comps
: Node_Id
) return List_Id
;
7136 -- Build all necessary adjust statements for a single component list
7138 ---------------------------------------
7139 -- Process_Component_List_For_Adjust --
7140 ---------------------------------------
7142 function Process_Component_List_For_Adjust
7143 (Comps
: Node_Id
) return List_Id
7145 Stmts
: constant List_Id
:= New_List
;
7147 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7148 -- Process the declaration of a single controlled component
7150 ----------------------------------
7151 -- Process_Component_For_Adjust --
7152 ----------------------------------
7154 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7155 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7156 Typ
: constant Entity_Id
:= Etype
(Id
);
7162 -- [Deep_]Adjust (V.Id);
7166 -- if not Raised then
7168 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7175 Make_Selected_Component
(Loc
,
7176 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7177 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7180 -- Guard against a missing [Deep_]Adjust when the component
7181 -- type was not properly frozen.
7183 if Present
(Adj_Call
) then
7184 if Exceptions_OK
then
7186 Make_Block_Statement
(Loc
,
7187 Handled_Statement_Sequence
=>
7188 Make_Handled_Sequence_Of_Statements
(Loc
,
7189 Statements
=> New_List
(Adj_Call
),
7190 Exception_Handlers
=> New_List
(
7191 Build_Exception_Handler
(Finalizer_Data
))));
7194 Append_To
(Stmts
, Adj_Call
);
7196 end Process_Component_For_Adjust
;
7201 Decl_Id
: Entity_Id
;
7202 Decl_Typ
: Entity_Id
;
7207 -- Start of processing for Process_Component_List_For_Adjust
7210 -- Perform an initial check, determine the number of controlled
7211 -- components in the current list and whether at least one of them
7212 -- is per-object constrained.
7214 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7216 -- The processing in this routine is done in the following order:
7217 -- 1) Regular components
7218 -- 2) Per-object constrained components
7221 if Num_Comps
> 0 then
7223 -- Process all regular components in order of declarations
7225 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7226 while Present
(Decl
) loop
7227 Decl_Id
:= Defining_Identifier
(Decl
);
7228 Decl_Typ
:= Etype
(Decl_Id
);
7230 -- Skip _parent as well as per-object constrained components
7232 if Chars
(Decl_Id
) /= Name_uParent
7233 and then Needs_Finalization
(Decl_Typ
)
7235 if Has_Access_Constraint
(Decl_Id
)
7236 and then No
(Expression
(Decl
))
7240 Process_Component_For_Adjust
(Decl
);
7244 Next_Non_Pragma
(Decl
);
7247 -- Process all per-object constrained components in order of
7251 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7252 while Present
(Decl
) loop
7253 Decl_Id
:= Defining_Identifier
(Decl
);
7254 Decl_Typ
:= Etype
(Decl_Id
);
7258 if Chars
(Decl_Id
) /= Name_uParent
7259 and then Needs_Finalization
(Decl_Typ
)
7260 and then Has_Access_Constraint
(Decl_Id
)
7261 and then No
(Expression
(Decl
))
7263 Process_Component_For_Adjust
(Decl
);
7266 Next_Non_Pragma
(Decl
);
7271 -- Process all variants, if any
7274 if Present
(Variant_Part
(Comps
)) then
7276 Var_Alts
: constant List_Id
:= New_List
;
7280 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7281 while Present
(Var
) loop
7284 -- when <discrete choices> =>
7285 -- <adjust statements>
7287 Append_To
(Var_Alts
,
7288 Make_Case_Statement_Alternative
(Loc
,
7290 New_Copy_List
(Discrete_Choices
(Var
)),
7292 Process_Component_List_For_Adjust
(
7293 Component_List
(Var
))));
7295 Next_Non_Pragma
(Var
);
7299 -- case V.<discriminant> is
7300 -- when <discrete choices 1> =>
7301 -- <adjust statements 1>
7303 -- when <discrete choices N> =>
7304 -- <adjust statements N>
7308 Make_Case_Statement
(Loc
,
7310 Make_Selected_Component
(Loc
,
7311 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7313 Make_Identifier
(Loc
,
7314 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7315 Alternatives
=> Var_Alts
);
7319 -- Add the variant case statement to the list of statements
7321 if Present
(Var_Case
) then
7322 Append_To
(Stmts
, Var_Case
);
7325 -- If the component list did not have any controlled components
7326 -- nor variants, return null.
7328 if Is_Empty_List
(Stmts
) then
7329 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7333 end Process_Component_List_For_Adjust
;
7337 Bod_Stmts
: List_Id
:= No_List
;
7338 Finalizer_Decls
: List_Id
:= No_List
;
7341 -- Start of processing for Build_Adjust_Statements
7344 Finalizer_Decls
:= New_List
;
7345 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7347 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7348 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7353 -- Create an adjust sequence for all record components
7355 if Present
(Component_List
(Rec_Def
)) then
7357 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7360 -- A derived record type must adjust all inherited components. This
7361 -- action poses the following problem:
7363 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7368 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7370 -- Deep_Adjust (Obj._parent);
7375 -- Adjusting the derived type will invoke Adjust of the parent and
7376 -- then that of the derived type. This is undesirable because both
7377 -- routines may modify shared components. Only the Adjust of the
7378 -- derived type should be invoked.
7380 -- To prevent this double adjustment of shared components,
7381 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7383 -- procedure Deep_Adjust
7384 -- (Obj : in out Some_Type;
7385 -- Flag : Boolean := True)
7393 -- When Deep_Adjust is invoked for field _parent, a value of False is
7394 -- provided for the flag:
7396 -- Deep_Adjust (Obj._parent, False);
7398 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7400 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7405 if Needs_Finalization
(Par_Typ
) then
7409 Make_Selected_Component
(Loc
,
7410 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7412 Make_Identifier
(Loc
, Name_uParent
)),
7418 -- Deep_Adjust (V._parent, False);
7421 -- when Id : others =>
7422 -- if not Raised then
7424 -- Save_Occurrence (E,
7425 -- Get_Current_Excep.all.all);
7429 if Present
(Call
) then
7432 if Exceptions_OK
then
7434 Make_Block_Statement
(Loc
,
7435 Handled_Statement_Sequence
=>
7436 Make_Handled_Sequence_Of_Statements
(Loc
,
7437 Statements
=> New_List
(Adj_Stmt
),
7438 Exception_Handlers
=> New_List
(
7439 Build_Exception_Handler
(Finalizer_Data
))));
7442 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7448 -- Adjust the object. This action must be performed last after all
7449 -- components have been adjusted.
7451 if Is_Controlled
(Typ
) then
7457 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7466 -- if not Raised then
7468 -- Save_Occurrence (E,
7469 -- Get_Current_Excep.all.all);
7474 if Present
(Proc
) then
7476 Make_Procedure_Call_Statement
(Loc
,
7477 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7478 Parameter_Associations
=> New_List
(
7479 Make_Identifier
(Loc
, Name_V
)));
7481 if Exceptions_OK
then
7483 Make_Block_Statement
(Loc
,
7484 Handled_Statement_Sequence
=>
7485 Make_Handled_Sequence_Of_Statements
(Loc
,
7486 Statements
=> New_List
(Adj_Stmt
),
7487 Exception_Handlers
=> New_List
(
7488 Build_Exception_Handler
7489 (Finalizer_Data
))));
7492 Append_To
(Bod_Stmts
,
7493 Make_If_Statement
(Loc
,
7494 Condition
=> Make_Identifier
(Loc
, Name_F
),
7495 Then_Statements
=> New_List
(Adj_Stmt
)));
7500 -- At this point either all adjustment statements have been generated
7501 -- or the type is not controlled.
7503 if Is_Empty_List
(Bod_Stmts
) then
7504 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7510 -- Abort : constant Boolean := Triggered_By_Abort;
7512 -- Abort : constant Boolean := False; -- no abort
7514 -- E : Exception_Occurrence;
7515 -- Raised : Boolean := False;
7518 -- <adjust statements>
7520 -- if Raised and then not Abort then
7521 -- Raise_From_Controlled_Operation (E);
7526 if Exceptions_OK
then
7527 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7532 Make_Block_Statement
(Loc
,
7535 Handled_Statement_Sequence
=>
7536 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7538 end Build_Adjust_Statements
;
7540 -------------------------------
7541 -- Build_Finalize_Statements --
7542 -------------------------------
7544 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7545 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7546 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7549 Finalizer_Data
: Finalization_Exception_Data
;
7550 Last_POC_Call
: Node_Id
:= Empty
;
7552 function Process_Component_List_For_Finalize
7554 In_Variant_Part
: Boolean := False) return List_Id
;
7555 -- Build all necessary finalization statements for a single component
7556 -- list. The statements may include a jump circuitry if flag Is_Local
7557 -- is enabled. In_Variant_Part indicates whether this is a recursive
7560 -----------------------------------------
7561 -- Process_Component_List_For_Finalize --
7562 -----------------------------------------
7564 function Process_Component_List_For_Finalize
7566 In_Variant_Part
: Boolean := False) return List_Id
7568 procedure Process_Component_For_Finalize
7573 Num_Comps
: in out Nat
);
7574 -- Process the declaration of a single controlled component. If
7575 -- flag Is_Local is enabled, create the corresponding label and
7576 -- jump circuitry. Alts is the list of case alternatives, Decls
7577 -- is the top level declaration list where labels are declared
7578 -- and Stmts is the list of finalization actions. Num_Comps
7579 -- denotes the current number of components needing finalization.
7581 ------------------------------------
7582 -- Process_Component_For_Finalize --
7583 ------------------------------------
7585 procedure Process_Component_For_Finalize
7590 Num_Comps
: in out Nat
)
7592 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7593 Typ
: constant Entity_Id
:= Etype
(Id
);
7600 Label_Id
: Entity_Id
;
7607 Make_Identifier
(Loc
,
7608 Chars
=> New_External_Name
('L', Num_Comps
));
7609 Set_Entity
(Label_Id
,
7610 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7611 Label
:= Make_Label
(Loc
, Label_Id
);
7614 Make_Implicit_Label_Declaration
(Loc
,
7615 Defining_Identifier
=> Entity
(Label_Id
),
7616 Label_Construct
=> Label
));
7623 Make_Case_Statement_Alternative
(Loc
,
7624 Discrete_Choices
=> New_List
(
7625 Make_Integer_Literal
(Loc
, Num_Comps
)),
7627 Statements
=> New_List
(
7628 Make_Goto_Statement
(Loc
,
7630 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7635 Append_To
(Stmts
, Label
);
7637 -- Decrease the number of components to be processed.
7638 -- This action yields a new Label_Id in future calls.
7640 Num_Comps
:= Num_Comps
- 1;
7645 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7647 -- begin -- Exception handlers allowed
7648 -- [Deep_]Finalize (V.Id);
7651 -- if not Raised then
7653 -- Save_Occurrence (E,
7654 -- Get_Current_Excep.all.all);
7661 Make_Selected_Component
(Loc
,
7662 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7663 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7666 -- Guard against a missing [Deep_]Finalize when the component
7667 -- type was not properly frozen.
7669 if Present
(Fin_Call
) then
7670 if Exceptions_OK
then
7672 Make_Block_Statement
(Loc
,
7673 Handled_Statement_Sequence
=>
7674 Make_Handled_Sequence_Of_Statements
(Loc
,
7675 Statements
=> New_List
(Fin_Call
),
7676 Exception_Handlers
=> New_List
(
7677 Build_Exception_Handler
(Finalizer_Data
))));
7680 Append_To
(Stmts
, Fin_Call
);
7682 end Process_Component_For_Finalize
;
7687 Counter_Id
: Entity_Id
:= Empty
;
7689 Decl_Id
: Entity_Id
;
7690 Decl_Typ
: Entity_Id
;
7693 Jump_Block
: Node_Id
;
7695 Label_Id
: Entity_Id
;
7700 -- Start of processing for Process_Component_List_For_Finalize
7703 -- Perform an initial check, look for controlled and per-object
7704 -- constrained components.
7706 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7708 -- Create a state counter to service the current component list.
7709 -- This step is performed before the variants are inspected in
7710 -- order to generate the same state counter names as those from
7711 -- Build_Initialize_Statements.
7713 if Num_Comps
> 0 and then Is_Local
then
7714 Counter
:= Counter
+ 1;
7717 Make_Defining_Identifier
(Loc
,
7718 Chars
=> New_External_Name
('C', Counter
));
7721 -- Process the component in the following order:
7723 -- 2) Per-object constrained components
7724 -- 3) Regular components
7726 -- Start with the variant parts
7729 if Present
(Variant_Part
(Comps
)) then
7731 Var_Alts
: constant List_Id
:= New_List
;
7735 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7736 while Present
(Var
) loop
7739 -- when <discrete choices> =>
7740 -- <finalize statements>
7742 Append_To
(Var_Alts
,
7743 Make_Case_Statement_Alternative
(Loc
,
7745 New_Copy_List
(Discrete_Choices
(Var
)),
7747 Process_Component_List_For_Finalize
(
7748 Component_List
(Var
),
7749 In_Variant_Part
=> True)));
7751 Next_Non_Pragma
(Var
);
7755 -- case V.<discriminant> is
7756 -- when <discrete choices 1> =>
7757 -- <finalize statements 1>
7759 -- when <discrete choices N> =>
7760 -- <finalize statements N>
7764 Make_Case_Statement
(Loc
,
7766 Make_Selected_Component
(Loc
,
7767 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7769 Make_Identifier
(Loc
,
7770 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7771 Alternatives
=> Var_Alts
);
7775 -- The current component list does not have a single controlled
7776 -- component, however it may contain variants. Return the case
7777 -- statement for the variants or nothing.
7779 if Num_Comps
= 0 then
7780 if Present
(Var_Case
) then
7781 return New_List
(Var_Case
);
7783 return New_List
(Make_Null_Statement
(Loc
));
7787 -- Prepare all lists
7793 -- Process all per-object constrained components in reverse order
7796 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7797 while Present
(Decl
) loop
7798 Decl_Id
:= Defining_Identifier
(Decl
);
7799 Decl_Typ
:= Etype
(Decl_Id
);
7803 if Chars
(Decl_Id
) /= Name_uParent
7804 and then Needs_Finalization
(Decl_Typ
)
7805 and then Has_Access_Constraint
(Decl_Id
)
7806 and then No
(Expression
(Decl
))
7808 Process_Component_For_Finalize
7809 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7812 Prev_Non_Pragma
(Decl
);
7816 if not In_Variant_Part
then
7817 Last_POC_Call
:= Last
(Stmts
);
7818 -- In the case of a type extension, the deep-finalize call
7819 -- for the _Parent component will be inserted here.
7822 -- Process the rest of the components in reverse order
7824 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7825 while Present
(Decl
) loop
7826 Decl_Id
:= Defining_Identifier
(Decl
);
7827 Decl_Typ
:= Etype
(Decl_Id
);
7831 if Chars
(Decl_Id
) /= Name_uParent
7832 and then Needs_Finalization
(Decl_Typ
)
7834 -- Skip per-object constrained components since they were
7835 -- handled in the above step.
7837 if Has_Access_Constraint
(Decl_Id
)
7838 and then No
(Expression
(Decl
))
7842 Process_Component_For_Finalize
7843 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7847 Prev_Non_Pragma
(Decl
);
7852 -- LN : label; -- If Is_Local is enabled
7857 -- case CounterX is .
7867 -- <<LN>> -- If Is_Local is enabled
7869 -- [Deep_]Finalize (V.CompY);
7871 -- when Id : others =>
7872 -- if not Raised then
7874 -- Save_Occurrence (E,
7875 -- Get_Current_Excep.all.all);
7879 -- <<L0>> -- If Is_Local is enabled
7884 -- Add the declaration of default jump location L0, its
7885 -- corresponding alternative and its place in the statements.
7887 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7888 Set_Entity
(Label_Id
,
7889 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7890 Label
:= Make_Label
(Loc
, Label_Id
);
7892 Append_To
(Decls
, -- declaration
7893 Make_Implicit_Label_Declaration
(Loc
,
7894 Defining_Identifier
=> Entity
(Label_Id
),
7895 Label_Construct
=> Label
));
7897 Append_To
(Alts
, -- alternative
7898 Make_Case_Statement_Alternative
(Loc
,
7899 Discrete_Choices
=> New_List
(
7900 Make_Others_Choice
(Loc
)),
7902 Statements
=> New_List
(
7903 Make_Goto_Statement
(Loc
,
7904 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7906 Append_To
(Stmts
, Label
); -- statement
7908 -- Create the jump block
7911 Make_Case_Statement
(Loc
,
7912 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7913 Alternatives
=> Alts
));
7917 Make_Block_Statement
(Loc
,
7918 Declarations
=> Decls
,
7919 Handled_Statement_Sequence
=>
7920 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7922 if Present
(Var_Case
) then
7923 return New_List
(Var_Case
, Jump_Block
);
7925 return New_List
(Jump_Block
);
7927 end Process_Component_List_For_Finalize
;
7931 Bod_Stmts
: List_Id
:= No_List
;
7932 Finalizer_Decls
: List_Id
:= No_List
;
7935 -- Start of processing for Build_Finalize_Statements
7938 Finalizer_Decls
:= New_List
;
7939 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7941 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7942 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7947 -- Create a finalization sequence for all record components
7949 if Present
(Component_List
(Rec_Def
)) then
7951 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7954 -- A derived record type must finalize all inherited components. This
7955 -- action poses the following problem:
7957 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7962 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7964 -- Deep_Finalize (Obj._parent);
7969 -- Finalizing the derived type will invoke Finalize of the parent and
7970 -- then that of the derived type. This is undesirable because both
7971 -- routines may modify shared components. Only the Finalize of the
7972 -- derived type should be invoked.
7974 -- To prevent this double adjustment of shared components,
7975 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7977 -- procedure Deep_Finalize
7978 -- (Obj : in out Some_Type;
7979 -- Flag : Boolean := True)
7987 -- When Deep_Finalize is invoked for field _parent, a value of False
7988 -- is provided for the flag:
7990 -- Deep_Finalize (Obj._parent, False);
7992 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7994 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7999 if Needs_Finalization
(Par_Typ
) then
8003 Make_Selected_Component
(Loc
,
8004 Prefix
=> Make_Identifier
(Loc
, Name_V
),
8006 Make_Identifier
(Loc
, Name_uParent
)),
8012 -- Deep_Finalize (V._parent, False);
8015 -- when Id : others =>
8016 -- if not Raised then
8018 -- Save_Occurrence (E,
8019 -- Get_Current_Excep.all.all);
8023 if Present
(Call
) then
8026 if Exceptions_OK
then
8028 Make_Block_Statement
(Loc
,
8029 Handled_Statement_Sequence
=>
8030 Make_Handled_Sequence_Of_Statements
(Loc
,
8031 Statements
=> New_List
(Fin_Stmt
),
8032 Exception_Handlers
=> New_List
(
8033 Build_Exception_Handler
8034 (Finalizer_Data
))));
8037 -- The intended component finalization order is
8038 -- 1) POC components of extension
8039 -- 2) _Parent component
8040 -- 3) non-POC components of extension.
8042 -- With this "finalize the parent part in the middle"
8043 -- ordering, we can avoid the need for making two
8044 -- calls to the parent's subprogram in the way that
8045 -- is necessary for Init_Procs. This does have the
8046 -- peculiar (but legal) consequence that the parent's
8047 -- non-POC components are finalized before the
8048 -- non-POC extension components. This violates the
8049 -- usual "finalize in reverse declaration order"
8050 -- principle, but that's ok (see Ada RM 7.6.1(9)).
8052 -- Last_POC_Call should be non-empty if the extension
8053 -- has at least one POC. Interactions with variant
8054 -- parts are incorrectly ignored.
8056 if Present
(Last_POC_Call
) then
8057 Insert_After
(Last_POC_Call
, Fin_Stmt
);
8059 -- At this point, we could look for the common case
8060 -- where there are no POC components anywhere in
8061 -- sight (inherited or not) and, in that common case,
8062 -- call Append_To instead of Prepend_To. That would
8063 -- result in finalizing the parent part after, rather
8064 -- than before, the extension components. That might
8065 -- be more intuitive (as discussed in preceding
8066 -- comment), but it is not required.
8067 Prepend_To
(Bod_Stmts
, Fin_Stmt
);
8074 -- Finalize the object. This action must be performed first before
8075 -- all components have been finalized.
8077 if Is_Controlled
(Typ
) and then not Is_Local
then
8083 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8092 -- if not Raised then
8094 -- Save_Occurrence (E,
8095 -- Get_Current_Excep.all.all);
8100 if Present
(Proc
) then
8102 Make_Procedure_Call_Statement
(Loc
,
8103 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8104 Parameter_Associations
=> New_List
(
8105 Make_Identifier
(Loc
, Name_V
)));
8107 if Exceptions_OK
then
8109 Make_Block_Statement
(Loc
,
8110 Handled_Statement_Sequence
=>
8111 Make_Handled_Sequence_Of_Statements
(Loc
,
8112 Statements
=> New_List
(Fin_Stmt
),
8113 Exception_Handlers
=> New_List
(
8114 Build_Exception_Handler
8115 (Finalizer_Data
))));
8118 Prepend_To
(Bod_Stmts
,
8119 Make_If_Statement
(Loc
,
8120 Condition
=> Make_Identifier
(Loc
, Name_F
),
8121 Then_Statements
=> New_List
(Fin_Stmt
)));
8126 -- At this point either all finalization statements have been
8127 -- generated or the type is not controlled.
8129 if No
(Bod_Stmts
) then
8130 return New_List
(Make_Null_Statement
(Loc
));
8134 -- Abort : constant Boolean := Triggered_By_Abort;
8136 -- Abort : constant Boolean := False; -- no abort
8138 -- E : Exception_Occurrence;
8139 -- Raised : Boolean := False;
8142 -- <finalize statements>
8144 -- if Raised and then not Abort then
8145 -- Raise_From_Controlled_Operation (E);
8150 if Exceptions_OK
then
8151 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8156 Make_Block_Statement
(Loc
,
8159 Handled_Statement_Sequence
=>
8160 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8162 end Build_Finalize_Statements
;
8164 -----------------------
8165 -- Parent_Field_Type --
8166 -----------------------
8168 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8172 Field
:= First_Entity
(Typ
);
8173 while Present
(Field
) loop
8174 if Chars
(Field
) = Name_uParent
then
8175 return Etype
(Field
);
8178 Next_Entity
(Field
);
8181 -- A derived tagged type should always have a parent field
8183 raise Program_Error
;
8184 end Parent_Field_Type
;
8186 ---------------------------
8187 -- Preprocess_Components --
8188 ---------------------------
8190 procedure Preprocess_Components
8192 Num_Comps
: out Nat
;
8193 Has_POC
: out Boolean)
8203 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8204 while Present
(Decl
) loop
8205 Id
:= Defining_Identifier
(Decl
);
8208 -- Skip field _parent
8210 if Chars
(Id
) /= Name_uParent
8211 and then Needs_Finalization
(Typ
)
8213 Num_Comps
:= Num_Comps
+ 1;
8215 if Has_Access_Constraint
(Id
)
8216 and then No
(Expression
(Decl
))
8222 Next_Non_Pragma
(Decl
);
8224 end Preprocess_Components
;
8226 -- Start of processing for Make_Deep_Record_Body
8230 when Address_Case
=>
8231 return Make_Finalize_Address_Stmts
(Typ
);
8234 return Build_Adjust_Statements
(Typ
);
8236 when Finalize_Case
=>
8237 return Build_Finalize_Statements
(Typ
);
8239 when Initialize_Case
=>
8241 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8244 if Is_Controlled
(Typ
) then
8246 Make_Procedure_Call_Statement
(Loc
,
8249 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8250 Parameter_Associations
=> New_List
(
8251 Make_Identifier
(Loc
, Name_V
))));
8257 end Make_Deep_Record_Body
;
8259 ----------------------
8260 -- Make_Final_Call --
8261 ----------------------
8263 function Make_Final_Call
8266 Skip_Self
: Boolean := False) return Node_Id
8268 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8270 Prot_Typ
: Entity_Id
:= Empty
;
8271 Fin_Id
: Entity_Id
:= Empty
;
8278 -- Recover the proper type which contains [Deep_]Finalize
8280 if Is_Class_Wide_Type
(Typ
) then
8281 Utyp
:= Root_Type
(Typ
);
8284 elsif Is_Concurrent_Type
(Typ
) then
8285 Utyp
:= Corresponding_Record_Type
(Typ
);
8287 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8289 elsif Is_Private_Type
(Typ
)
8290 and then Present
(Underlying_Type
(Typ
))
8291 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8293 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8295 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8302 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8303 Set_Assignment_OK
(Ref
);
8305 -- Deal with untagged derivation of private views. If the parent type
8306 -- is a protected type, Deep_Finalize is found on the corresponding
8307 -- record of the ancestor.
8309 if Is_Untagged_Derivation
(Typ
) then
8310 if Is_Protected_Type
(Typ
) then
8311 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8313 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8315 if Is_Protected_Type
(Utyp
) then
8316 Utyp
:= Corresponding_Record_Type
(Utyp
);
8320 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8321 Set_Assignment_OK
(Ref
);
8324 -- Deal with derived private types which do not inherit primitives from
8325 -- their parents. In this case, [Deep_]Finalize can be found in the full
8326 -- view of the parent type.
8329 and then Is_Tagged_Type
(Utyp
)
8330 and then Is_Derived_Type
(Utyp
)
8331 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8332 and then Is_Private_Type
(Etype
(Utyp
))
8333 and then Present
(Full_View
(Etype
(Utyp
)))
8335 Utyp
:= Full_View
(Etype
(Utyp
));
8336 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8337 Set_Assignment_OK
(Ref
);
8340 -- When dealing with the completion of a private type, use the base type
8343 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8344 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8346 Utyp
:= Base_Type
(Utyp
);
8347 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8348 Set_Assignment_OK
(Ref
);
8351 -- Detect if Typ is a protected type or an expanded protected type and
8352 -- store the relevant type within Prot_Typ for later processing.
8354 if Is_Protected_Type
(Typ
) then
8357 elsif Ekind
(Typ
) = E_Record_Type
8358 and then Present
(Corresponding_Concurrent_Type
(Typ
))
8359 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Typ
))
8361 Prot_Typ
:= Corresponding_Concurrent_Type
(Typ
);
8364 -- The underlying type may not be present due to a missing full view. In
8365 -- this case freezing did not take place and there is no [Deep_]Finalize
8366 -- primitive to call.
8371 elsif Skip_Self
then
8372 if Has_Controlled_Component
(Utyp
) then
8373 if Is_Tagged_Type
(Utyp
) then
8374 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8376 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8380 -- Class-wide types, interfaces and types with controlled components
8382 elsif Is_Class_Wide_Type
(Typ
)
8383 or else Is_Interface
(Typ
)
8384 or else Has_Controlled_Component
(Utyp
)
8386 if Is_Tagged_Type
(Utyp
) then
8387 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8389 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8392 -- Derivations from [Limited_]Controlled
8394 elsif Is_Controlled
(Utyp
) then
8395 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8399 elsif Is_Tagged_Type
(Utyp
) then
8400 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8402 -- Protected types: these also require finalization even though they
8403 -- are not marked controlled explicitly.
8405 elsif Present
(Prot_Typ
) then
8406 -- Protected objects do not need to be finalized on restricted
8409 if Restricted_Profile
then
8412 -- ??? Only handle the simple case for now. Will not support a record
8413 -- or array containing protected objects.
8415 elsif Is_Simple_Protected_Type
(Prot_Typ
) then
8416 Fin_Id
:= RTE
(RE_Finalize_Protection
);
8418 raise Program_Error
;
8421 raise Program_Error
;
8424 if Present
(Fin_Id
) then
8426 -- When finalizing a class-wide object, do not convert to the root
8427 -- type in order to produce a dispatching call.
8429 if Is_Class_Wide_Type
(Typ
) then
8432 -- Ensure that a finalization routine is at least decorated in order
8433 -- to inspect the object parameter.
8435 elsif Analyzed
(Fin_Id
)
8436 or else Ekind
(Fin_Id
) = E_Procedure
8438 -- In certain cases, such as the creation of Stream_Read, the
8439 -- visible entity of the type is its full view. Since Stream_Read
8440 -- will have to create an object of type Typ, the local object
8441 -- will be finalzed by the scope finalizer generated later on. The
8442 -- object parameter of Deep_Finalize will always use the private
8443 -- view of the type. To avoid such a clash between a private and a
8444 -- full view, perform an unchecked conversion of the object
8445 -- reference to the private view.
8448 Formal_Typ
: constant Entity_Id
:=
8449 Etype
(First_Formal
(Fin_Id
));
8451 if Is_Private_Type
(Formal_Typ
)
8452 and then Present
(Full_View
(Formal_Typ
))
8453 and then Full_View
(Formal_Typ
) = Utyp
8455 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8459 -- If the object is unanalyzed, set its expected type for use in
8460 -- Convert_View in case an additional conversion is needed.
8463 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
8465 Set_Etype
(Ref
, Typ
);
8468 Ref
:= Convert_View
(Fin_Id
, Ref
);
8475 Skip_Self
=> Skip_Self
);
8479 end Make_Final_Call
;
8481 --------------------------------
8482 -- Make_Finalize_Address_Body --
8483 --------------------------------
8485 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8486 Is_Task
: constant Boolean :=
8487 Ekind
(Typ
) = E_Record_Type
8488 and then Is_Concurrent_Record_Type
(Typ
)
8489 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8491 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8492 Proc_Id
: Entity_Id
;
8496 -- The corresponding records of task types are not controlled by design.
8497 -- For the sake of completeness, create an empty Finalize_Address to be
8498 -- used in task class-wide allocations.
8503 -- Nothing to do if the type is not controlled or it already has a
8504 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8505 -- come from source. These are usually generated for completeness and
8506 -- do not need the Finalize_Address primitive.
8508 elsif not Needs_Finalization
(Typ
)
8509 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8511 (Is_Class_Wide_Type
(Typ
)
8512 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8513 and then not Comes_From_Source
(Root_Type
(Typ
)))
8518 -- Do not generate Finalize_Address routine for CodePeer
8520 if CodePeer_Mode
then
8525 Make_Defining_Identifier
(Loc
,
8526 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8530 -- procedure <Typ>FD (V : System.Address) is
8532 -- null; -- for tasks
8534 -- declare -- for all other types
8535 -- type Pnn is access all Typ;
8536 -- for Pnn'Storage_Size use 0;
8538 -- [Deep_]Finalize (Pnn (V).all);
8543 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8545 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8549 Make_Subprogram_Body
(Loc
,
8551 Make_Procedure_Specification
(Loc
,
8552 Defining_Unit_Name
=> Proc_Id
,
8554 Parameter_Specifications
=> New_List
(
8555 Make_Parameter_Specification
(Loc
,
8556 Defining_Identifier
=>
8557 Make_Defining_Identifier
(Loc
, Name_V
),
8559 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8561 Declarations
=> No_List
,
8563 Handled_Statement_Sequence
=>
8564 Make_Handled_Sequence_Of_Statements
(Loc
,
8565 Statements
=> Stmts
)));
8567 Set_TSS
(Typ
, Proc_Id
);
8568 end Make_Finalize_Address_Body
;
8570 ---------------------------------
8571 -- Make_Finalize_Address_Stmts --
8572 ---------------------------------
8574 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8575 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8578 Desig_Typ
: Entity_Id
;
8579 Fin_Block
: Node_Id
;
8582 Ptr_Typ
: Entity_Id
;
8585 if Is_Array_Type
(Typ
) then
8586 if Is_Constrained
(First_Subtype
(Typ
)) then
8587 Desig_Typ
:= First_Subtype
(Typ
);
8589 Desig_Typ
:= Base_Type
(Typ
);
8592 -- Class-wide types of constrained root types
8594 elsif Is_Class_Wide_Type
(Typ
)
8595 and then Has_Discriminants
(Root_Type
(Typ
))
8597 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8600 Parent_Typ
: Entity_Id
;
8603 -- Climb the parent type chain looking for a non-constrained type
8605 Parent_Typ
:= Root_Type
(Typ
);
8606 while Parent_Typ
/= Etype
(Parent_Typ
)
8607 and then Has_Discriminants
(Parent_Typ
)
8609 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8611 Parent_Typ
:= Etype
(Parent_Typ
);
8614 -- Handle views created for tagged types with unknown
8617 if Is_Underlying_Record_View
(Parent_Typ
) then
8618 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8621 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
8631 -- type Ptr_Typ is access all Typ;
8632 -- for Ptr_Typ'Storage_Size use 0;
8634 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8637 Make_Full_Type_Declaration
(Loc
,
8638 Defining_Identifier
=> Ptr_Typ
,
8640 Make_Access_To_Object_Definition
(Loc
,
8641 All_Present
=> True,
8642 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8644 Make_Attribute_Definition_Clause
(Loc
,
8645 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8646 Chars
=> Name_Storage_Size
,
8647 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8649 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8651 -- Unconstrained arrays require special processing in order to retrieve
8652 -- the elements. To achieve this, we have to skip the dope vector which
8653 -- lays in front of the elements and then use a thin pointer to perform
8654 -- the address-to-access conversion.
8656 if Is_Array_Type
(Typ
)
8657 and then not Is_Constrained
(First_Subtype
(Typ
))
8660 Dope_Id
: Entity_Id
;
8663 -- Ensure that Ptr_Typ is a thin pointer; generate:
8664 -- for Ptr_Typ'Size use System.Address'Size;
8667 Make_Attribute_Definition_Clause
(Loc
,
8668 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8671 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8674 -- Dnn : constant Storage_Offset :=
8675 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8677 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8680 Make_Object_Declaration
(Loc
,
8681 Defining_Identifier
=> Dope_Id
,
8682 Constant_Present
=> True,
8683 Object_Definition
=>
8684 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8686 Make_Op_Divide
(Loc
,
8688 Make_Attribute_Reference
(Loc
,
8689 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8690 Attribute_Name
=> Name_Descriptor_Size
),
8692 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8694 -- Shift the address from the start of the dope vector to the
8695 -- start of the elements:
8699 -- Note that this is done through a wrapper routine since RTSfind
8700 -- cannot retrieve operations with string names of the form "+".
8703 Make_Function_Call
(Loc
,
8705 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8706 Parameter_Associations
=> New_List
(
8708 New_Occurrence_Of
(Dope_Id
, Loc
)));
8715 Make_Explicit_Dereference
(Loc
,
8716 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8719 if Present
(Fin_Call
) then
8721 Make_Block_Statement
(Loc
,
8722 Declarations
=> Decls
,
8723 Handled_Statement_Sequence
=>
8724 Make_Handled_Sequence_Of_Statements
(Loc
,
8725 Statements
=> New_List
(Fin_Call
)));
8727 -- Otherwise previous errors or a missing full view may prevent the
8728 -- proper freezing of the designated type. If this is the case, there
8729 -- is no [Deep_]Finalize primitive to call.
8732 Fin_Block
:= Make_Null_Statement
(Loc
);
8735 return New_List
(Fin_Block
);
8736 end Make_Finalize_Address_Stmts
;
8738 -------------------------------------
8739 -- Make_Handler_For_Ctrl_Operation --
8740 -------------------------------------
8744 -- when E : others =>
8745 -- Raise_From_Controlled_Operation (E);
8750 -- raise Program_Error [finalize raised exception];
8752 -- depending on whether Raise_From_Controlled_Operation is available
8754 function Make_Handler_For_Ctrl_Operation
8755 (Loc
: Source_Ptr
) return Node_Id
8758 -- Choice parameter (for the first case above)
8760 Raise_Node
: Node_Id
;
8761 -- Procedure call or raise statement
8764 -- Standard run-time: add choice parameter E and pass it to
8765 -- Raise_From_Controlled_Operation so that the original exception
8766 -- name and message can be recorded in the exception message for
8769 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8770 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8772 Make_Procedure_Call_Statement
(Loc
,
8775 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8776 Parameter_Associations
=> New_List
(
8777 New_Occurrence_Of
(E_Occ
, Loc
)));
8779 -- Restricted run-time: exception messages are not supported
8784 Make_Raise_Program_Error
(Loc
,
8785 Reason
=> PE_Finalize_Raised_Exception
);
8789 Make_Implicit_Exception_Handler
(Loc
,
8790 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8791 Choice_Parameter
=> E_Occ
,
8792 Statements
=> New_List
(Raise_Node
));
8793 end Make_Handler_For_Ctrl_Operation
;
8795 --------------------
8796 -- Make_Init_Call --
8797 --------------------
8799 function Make_Init_Call
8801 Typ
: Entity_Id
) return Node_Id
8803 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8812 -- Deal with the type and object reference. Depending on the context, an
8813 -- object reference may need several conversions.
8815 if Is_Concurrent_Type
(Typ
) then
8817 Utyp
:= Corresponding_Record_Type
(Typ
);
8818 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8820 elsif Is_Private_Type
(Typ
)
8821 and then Present
(Full_View
(Typ
))
8822 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8825 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8826 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8833 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8834 Set_Assignment_OK
(Ref
);
8836 -- Deal with untagged derivation of private views
8838 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8839 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8840 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8842 -- The following is to prevent problems with UC see 1.156 RH ???
8844 Set_Assignment_OK
(Ref
);
8847 -- If the underlying_type is a subtype, then we are dealing with the
8848 -- completion of a private type. We need to access the base type and
8849 -- generate a conversion to it.
8851 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8852 pragma Assert
(Is_Private_Type
(Typ
));
8853 Utyp
:= Base_Type
(Utyp
);
8854 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8857 -- The underlying type may not be present due to a missing full view.
8858 -- In this case freezing did not take place and there is no suitable
8859 -- [Deep_]Initialize primitive to call.
8860 -- If Typ is protected then no additional processing is needed either.
8863 or else Is_Protected_Type
(Typ
)
8868 -- Select the appropriate version of initialize
8870 if Has_Controlled_Component
(Utyp
) then
8871 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8873 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8874 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8877 -- If initialization procedure for an array of controlled objects is
8878 -- trivial, do not generate a useless call to it.
8879 -- The initialization procedure may be missing altogether in the case
8880 -- of a derived container whose components have trivial initialization.
8883 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8885 (not Comes_From_Source
(Proc
)
8886 and then Present
(Alias
(Proc
))
8887 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8892 -- The object reference may need another conversion depending on the
8893 -- type of the formal and that of the actual.
8895 Ref
:= Convert_View
(Proc
, Ref
);
8898 -- [Deep_]Initialize (Ref);
8901 Make_Procedure_Call_Statement
(Loc
,
8902 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8903 Parameter_Associations
=> New_List
(Ref
));
8906 ------------------------------
8907 -- Make_Local_Deep_Finalize --
8908 ------------------------------
8910 function Make_Local_Deep_Finalize
8912 Nam
: Entity_Id
) return Node_Id
8914 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8918 Formals
:= New_List
(
8922 Make_Parameter_Specification
(Loc
,
8923 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8925 Out_Present
=> True,
8926 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8928 -- F : Boolean := True
8930 Make_Parameter_Specification
(Loc
,
8931 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8932 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8933 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8935 -- Add the necessary number of counters to represent the initialization
8936 -- state of an object.
8939 Make_Subprogram_Body
(Loc
,
8941 Make_Procedure_Specification
(Loc
,
8942 Defining_Unit_Name
=> Nam
,
8943 Parameter_Specifications
=> Formals
),
8945 Declarations
=> No_List
,
8947 Handled_Statement_Sequence
=>
8948 Make_Handled_Sequence_Of_Statements
(Loc
,
8949 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8950 end Make_Local_Deep_Finalize
;
8952 ------------------------------------
8953 -- Make_Set_Finalize_Address_Call --
8954 ------------------------------------
8956 function Make_Set_Finalize_Address_Call
8958 Ptr_Typ
: Entity_Id
) return Node_Id
8960 -- It is possible for Ptr_Typ to be a partial view, if the access type
8961 -- is a full view declared in the private part of a nested package, and
8962 -- the finalization actions take place when completing analysis of the
8963 -- enclosing unit. For this reason use Underlying_Type twice below.
8965 Desig_Typ
: constant Entity_Id
:=
8967 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8968 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8969 Fin_Mas
: constant Entity_Id
:=
8970 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8973 -- Both the finalization master and primitive Finalize_Address must be
8976 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8979 -- Set_Finalize_Address
8980 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8983 Make_Procedure_Call_Statement
(Loc
,
8985 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8986 Parameter_Associations
=> New_List
(
8987 New_Occurrence_Of
(Fin_Mas
, Loc
),
8989 Make_Attribute_Reference
(Loc
,
8990 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8991 Attribute_Name
=> Name_Unrestricted_Access
)));
8992 end Make_Set_Finalize_Address_Call
;
8994 --------------------------
8995 -- Make_Transient_Block --
8996 --------------------------
8998 function Make_Transient_Block
9001 Par
: Node_Id
) return Node_Id
9003 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
9004 -- Determine whether scoping entity Id manages the secondary stack
9006 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
9007 -- Return True when N appears within a loop and no block is containing N
9009 -----------------------
9010 -- Manages_Sec_Stack --
9011 -----------------------
9013 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
9017 -- An exception handler with a choice parameter utilizes a dummy
9018 -- block to provide a declarative region. Such a block should not
9019 -- be considered because it never manifests in the tree and can
9020 -- never release the secondary stack.
9024 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
9031 return Uses_Sec_Stack
(Id
);
9036 end Manages_Sec_Stack
;
9038 ---------------------------
9039 -- Within_Loop_Statement --
9040 ---------------------------
9042 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
9043 Par
: Node_Id
:= Parent
(N
);
9046 while Nkind
(Par
) not in
9047 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9048 N_Package_Specification | N_Proper_Body
9050 pragma Assert
(Present
(Par
));
9051 Par
:= Parent
(Par
);
9054 return Nkind
(Par
) = N_Loop_Statement
;
9055 end Within_Loop_Statement
;
9059 Decls
: constant List_Id
:= New_List
;
9060 Instrs
: constant List_Id
:= New_List
(Action
);
9061 Trans_Id
: constant Entity_Id
:= Current_Scope
;
9067 -- Start of processing for Make_Transient_Block
9070 -- Even though the transient block is tasked with managing the secondary
9071 -- stack, the block may forgo this functionality depending on how the
9072 -- secondary stack is managed by enclosing scopes.
9074 if Manages_Sec_Stack
(Trans_Id
) then
9076 -- Determine whether an enclosing scope already manages the secondary
9079 Scop
:= Scope
(Trans_Id
);
9080 while Present
(Scop
) loop
9082 -- It should not be possible to reach Standard without hitting one
9083 -- of the other cases first unless Standard was manually pushed.
9085 if Scop
= Standard_Standard
then
9088 -- The transient block is within a function which returns on the
9089 -- secondary stack. Take a conservative approach and assume that
9090 -- the value on the secondary stack is part of the result. Note
9091 -- that it is not possible to detect this dependency without flow
9092 -- analysis which the compiler does not have. Letting the object
9093 -- live longer than the transient block will not leak any memory
9094 -- because the caller will reclaim the total storage used by the
9097 elsif Ekind
(Scop
) = E_Function
9098 and then Sec_Stack_Needed_For_Return
(Scop
)
9100 Set_Uses_Sec_Stack
(Trans_Id
, False);
9103 -- The transient block must manage the secondary stack when the
9104 -- block appears within a loop in order to reclaim the memory at
9107 elsif Ekind
(Scop
) = E_Loop
then
9110 -- Ditto when the block appears without a block that does not
9111 -- manage the secondary stack and is located within a loop.
9113 elsif Ekind
(Scop
) = E_Block
9114 and then not Manages_Sec_Stack
(Scop
)
9115 and then Present
(Block_Node
(Scop
))
9116 and then Within_Loop_Statement
(Block_Node
(Scop
))
9120 -- The transient block does not need to manage the secondary stack
9121 -- when there is an enclosing construct which already does that.
9122 -- This optimization saves on SS_Mark and SS_Release calls but may
9123 -- allow objects to live a little longer than required.
9125 -- The transient block must manage the secondary stack when switch
9126 -- -gnatd.s (strict management) is in effect.
9128 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9129 Set_Uses_Sec_Stack
(Trans_Id
, False);
9132 -- Prevent the search from going too far because transient blocks
9133 -- are bounded by packages and subprogram scopes.
9135 elsif Ekind
(Scop
) in E_Entry
9145 Scop
:= Scope
(Scop
);
9149 -- Create the transient block. Set the parent now since the block itself
9150 -- is not part of the tree. The current scope is the E_Block entity that
9151 -- has been pushed by Establish_Transient_Scope.
9153 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9156 Make_Block_Statement
(Loc
,
9157 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9158 Declarations
=> Decls
,
9159 Handled_Statement_Sequence
=>
9160 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9161 Has_Created_Identifier
=> True);
9162 Set_Parent
(Block
, Par
);
9164 -- Insert actions stuck in the transient scopes as well as all freezing
9165 -- nodes needed by those actions. Do not insert cleanup actions here,
9166 -- they will be transferred to the newly created block.
9168 Insert_Actions_In_Scope_Around
9169 (Action
, Clean
=> False, Manage_SS
=> False);
9171 Insert
:= Prev
(Action
);
9173 if Present
(Insert
) then
9174 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9177 -- Transfer cleanup actions to the newly created block
9180 Cleanup_Actions
: List_Id
9181 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9182 Actions_To_Be_Wrapped
(Cleanup
);
9184 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9185 Cleanup_Actions
:= No_List
;
9188 -- When the transient scope was established, we pushed the entry for the
9189 -- transient scope onto the scope stack, so that the scope was active
9190 -- for the installation of finalizable entities etc. Now we must remove
9191 -- this entry, since we have constructed a proper block.
9196 end Make_Transient_Block
;
9198 ------------------------
9199 -- Node_To_Be_Wrapped --
9200 ------------------------
9202 function Node_To_Be_Wrapped
return Node_Id
is
9204 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9205 end Node_To_Be_Wrapped
;
9207 ----------------------------
9208 -- Store_Actions_In_Scope --
9209 ----------------------------
9211 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9212 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9213 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9216 if Is_Empty_List
(Actions
) then
9219 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9220 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9222 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9227 elsif AK
= Before
then
9228 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9231 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9233 end Store_Actions_In_Scope
;
9235 ----------------------------------
9236 -- Store_After_Actions_In_Scope --
9237 ----------------------------------
9239 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9241 Store_Actions_In_Scope
(After
, L
);
9242 end Store_After_Actions_In_Scope
;
9244 -----------------------------------
9245 -- Store_Before_Actions_In_Scope --
9246 -----------------------------------
9248 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9250 Store_Actions_In_Scope
(Before
, L
);
9251 end Store_Before_Actions_In_Scope
;
9253 -----------------------------------
9254 -- Store_Cleanup_Actions_In_Scope --
9255 -----------------------------------
9257 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9259 Store_Actions_In_Scope
(Cleanup
, L
);
9260 end Store_Cleanup_Actions_In_Scope
;
9266 procedure Unnest_Block
(Decl
: Node_Id
) is
9267 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9269 Local_Body
: Node_Id
;
9270 Local_Call
: Node_Id
;
9271 Local_Proc
: Entity_Id
;
9272 Local_Scop
: Entity_Id
;
9275 Local_Scop
:= Entity
(Identifier
(Decl
));
9276 Ent
:= First_Entity
(Local_Scop
);
9278 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9281 Make_Subprogram_Body
(Loc
,
9283 Make_Procedure_Specification
(Loc
,
9284 Defining_Unit_Name
=> Local_Proc
),
9285 Declarations
=> Declarations
(Decl
),
9286 Handled_Statement_Sequence
=>
9287 Handled_Statement_Sequence
(Decl
));
9289 -- Handlers in the block may contain nested subprograms that require
9292 Check_Unnesting_In_Handlers
(Local_Body
);
9294 Rewrite
(Decl
, Local_Body
);
9296 Set_Has_Nested_Subprogram
(Local_Proc
);
9299 Make_Procedure_Call_Statement
(Loc
,
9300 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9302 Insert_After
(Decl
, Local_Call
);
9303 Analyze
(Local_Call
);
9305 -- The new subprogram has the same scope as the original block
9307 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9309 -- And the entity list of the new procedure is that of the block
9311 Set_First_Entity
(Local_Proc
, Ent
);
9313 -- Reset the scopes of all the entities to the new procedure
9315 while Present
(Ent
) loop
9316 Set_Scope
(Ent
, Local_Proc
);
9321 -------------------------
9322 -- Unnest_If_Statement --
9323 -------------------------
9325 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
9327 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
9328 -- A list of statements (that may be a list associated with a then,
9329 -- elsif, or else part of an if-statement) is traversed at the top
9330 -- level to determine whether it contains a subprogram body, and if so,
9331 -- the statements will be replaced with a new procedure body containing
9332 -- the statements followed by a call to the procedure. The individual
9333 -- statements may also be blocks, loops, or other if statements that
9334 -- themselves may require contain nested subprograms needing unnesting.
9336 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
9337 Subp_Found
: Boolean := False;
9340 if Is_Empty_List
(Stmts
) then
9345 Stmt
: Node_Id
:= First
(Stmts
);
9347 while Present
(Stmt
) loop
9348 if Nkind
(Stmt
) = N_Subprogram_Body
then
9357 -- The statements themselves may be blocks, loops, etc. that in turn
9358 -- contain nested subprograms requiring an unnesting transformation.
9359 -- We perform this traversal after looking for subprogram bodies, to
9360 -- avoid considering procedures created for one of those statements
9361 -- (such as a block rewritten as a procedure) as a nested subprogram
9362 -- of the statement list (which could result in an unneeded wrapper
9365 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
9367 -- If there was a top-level subprogram body in the statement list,
9368 -- then perform an unnesting transformation on the list by replacing
9369 -- the statements with a wrapper procedure body containing the
9370 -- original statements followed by a call to that procedure.
9373 Unnest_Statement_List
(Stmts
);
9375 end Check_Stmts_For_Subp_Unnesting
;
9379 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
9380 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
9382 -- Start of processing for Unnest_If_Statement
9385 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
9386 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
9388 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
9390 Elsif_Part
: Node_Id
:=
9391 First
(Elsif_Parts
(If_Stmt
));
9392 Elsif_Stmts
: List_Id
;
9394 while Present
(Elsif_Part
) loop
9395 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
9397 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
9398 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
9405 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
9406 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
9407 end Unnest_If_Statement
;
9413 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
9414 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
9416 Local_Body
: Node_Id
;
9417 Local_Call
: Node_Id
;
9418 Local_Proc
: Entity_Id
;
9419 Local_Scop
: Entity_Id
;
9420 Loop_Copy
: constant Node_Id
:=
9421 Relocate_Node
(Loop_Stmt
);
9423 Local_Scop
:= Entity
(Identifier
(Loop_Stmt
));
9424 Ent
:= First_Entity
(Local_Scop
);
9426 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9429 Make_Subprogram_Body
(Loc
,
9431 Make_Procedure_Specification
(Loc
,
9432 Defining_Unit_Name
=> Local_Proc
),
9433 Declarations
=> Empty_List
,
9434 Handled_Statement_Sequence
=>
9435 Make_Handled_Sequence_Of_Statements
(Loc
,
9436 Statements
=> New_List
(Loop_Copy
)));
9438 Rewrite
(Loop_Stmt
, Local_Body
);
9439 Analyze
(Loop_Stmt
);
9441 Set_Has_Nested_Subprogram
(Local_Proc
);
9444 Make_Procedure_Call_Statement
(Loc
,
9445 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9447 Insert_After
(Loop_Stmt
, Local_Call
);
9448 Analyze
(Local_Call
);
9450 -- New procedure has the same scope as the original loop, and the scope
9451 -- of the loop is the new procedure.
9453 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9454 Set_Scope
(Local_Scop
, Local_Proc
);
9456 -- The entity list of the new procedure is that of the loop
9458 Set_First_Entity
(Local_Proc
, Ent
);
9460 -- Note that the entities associated with the loop don't need to have
9461 -- their Scope fields reset, since they're still associated with the
9462 -- same loop entity that now belongs to the copied loop statement.
9465 ---------------------------
9466 -- Unnest_Statement_List --
9467 ---------------------------
9469 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
9470 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
9471 Local_Body
: Node_Id
;
9472 Local_Call
: Node_Id
;
9473 Local_Proc
: Entity_Id
;
9474 New_Stmts
: constant List_Id
:= Empty_List
;
9477 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9480 Make_Subprogram_Body
(Loc
,
9482 Make_Procedure_Specification
(Loc
,
9483 Defining_Unit_Name
=> Local_Proc
),
9484 Declarations
=> Empty_List
,
9485 Handled_Statement_Sequence
=>
9486 Make_Handled_Sequence_Of_Statements
(Loc
,
9487 Statements
=> Stmts
));
9489 Append_To
(New_Stmts
, Local_Body
);
9491 Analyze
(Local_Body
);
9493 Set_Has_Nested_Subprogram
(Local_Proc
);
9496 Make_Procedure_Call_Statement
(Loc
,
9497 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9499 Append_To
(New_Stmts
, Local_Call
);
9500 Analyze
(Local_Call
);
9502 -- Traverse the statements, and for any that are declarations or
9503 -- subprogram bodies that have entities, set the Scope of those
9504 -- entities to the new procedure's Entity_Id.
9507 Stmt
: Node_Id
:= First
(Stmts
);
9510 while Present
(Stmt
) loop
9511 case Nkind
(Stmt
) is
9513 | N_Renaming_Declaration
9515 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
9517 when N_Subprogram_Body
=>
9519 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
9530 end Unnest_Statement_List
;
9532 --------------------------------
9533 -- Wrap_Transient_Declaration --
9534 --------------------------------
9536 -- If a transient scope has been established during the processing of the
9537 -- Expression of an Object_Declaration, it is not possible to wrap the
9538 -- declaration into a transient block as usual case, otherwise the object
9539 -- would be itself declared in the wrong scope. Therefore, all entities (if
9540 -- any) defined in the transient block are moved to the proper enclosing
9541 -- scope. Furthermore, if they are controlled variables they are finalized
9542 -- right after the declaration. The finalization list of the transient
9543 -- scope is defined as a renaming of the enclosing one so during their
9544 -- initialization they will be attached to the proper finalization list.
9545 -- For instance, the following declaration :
9547 -- X : Typ := F (G (A), G (B));
9549 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9550 -- is expanded into :
9552 -- X : Typ := [ complex Expression-Action ];
9553 -- [Deep_]Finalize (_v1);
9554 -- [Deep_]Finalize (_v2);
9556 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9561 Curr_S
:= Current_Scope
;
9562 Encl_S
:= Scope
(Curr_S
);
9564 -- Insert all actions including cleanup generated while analyzing or
9565 -- expanding the transient context back into the tree. Manage the
9566 -- secondary stack when the object declaration appears in a library
9567 -- level package [body].
9569 Insert_Actions_In_Scope_Around
9573 Uses_Sec_Stack
(Curr_S
)
9574 and then Nkind
(N
) = N_Object_Declaration
9575 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
9576 and then Is_Library_Level_Entity
(Encl_S
));
9579 -- Relocate local entities declared within the transient scope to the
9580 -- enclosing scope. This action sets their Is_Public flag accordingly.
9582 Transfer_Entities
(Curr_S
, Encl_S
);
9584 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9585 -- is properly released upon exiting the said scope.
9587 if Uses_Sec_Stack
(Curr_S
) then
9588 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9590 -- Do not mark a function that returns on the secondary stack as the
9591 -- reclamation is done by the caller.
9593 if Ekind
(Curr_S
) = E_Function
9594 and then Needs_Secondary_Stack
(Etype
(Curr_S
))
9598 -- Otherwise mark the enclosing dynamic scope
9601 Set_Uses_Sec_Stack
(Curr_S
);
9602 Check_Restriction
(No_Secondary_Stack
, N
);
9605 end Wrap_Transient_Declaration
;
9607 -------------------------------
9608 -- Wrap_Transient_Expression --
9609 -------------------------------
9611 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9612 Loc
: constant Source_Ptr
:= Sloc
(N
);
9613 Expr
: Node_Id
:= Relocate_Node
(N
);
9614 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9615 Typ
: constant Entity_Id
:= Etype
(N
);
9622 -- M : constant Mark_Id := SS_Mark;
9623 -- procedure Finalizer is ... (See Build_Finalizer)
9626 -- Temp := <Expr>; -- general case
9627 -- Temp := (if <Expr> then True else False); -- boolean case
9633 -- A special case is made for Boolean expressions so that the back end
9634 -- knows to generate a conditional branch instruction, if running with
9635 -- -fpreserve-control-flow. This ensures that a control-flow change
9636 -- signaling the decision outcome occurs before the cleanup actions.
9638 if Opt
.Suppress_Control_Flow_Optimizations
9639 and then Is_Boolean_Type
(Typ
)
9642 Make_If_Expression
(Loc
,
9643 Expressions
=> New_List
(
9645 New_Occurrence_Of
(Standard_True
, Loc
),
9646 New_Occurrence_Of
(Standard_False
, Loc
)));
9649 Insert_Actions
(N
, New_List
(
9650 Make_Object_Declaration
(Loc
,
9651 Defining_Identifier
=> Temp
,
9652 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9654 Make_Transient_Block
(Loc
,
9656 Make_Assignment_Statement
(Loc
,
9657 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9658 Expression
=> Expr
),
9659 Par
=> Parent
(N
))));
9661 if Debug_Generated_Code
then
9662 Set_Debug_Info_Needed
(Temp
);
9665 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9666 Analyze_And_Resolve
(N
, Typ
);
9667 end Wrap_Transient_Expression
;
9669 ------------------------------
9670 -- Wrap_Transient_Statement --
9671 ------------------------------
9673 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9674 Loc
: constant Source_Ptr
:= Sloc
(N
);
9675 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9680 -- M : constant Mark_Id := SS_Mark;
9681 -- procedure Finalizer is ... (See Build_Finalizer)
9691 Make_Transient_Block
(Loc
,
9693 Par
=> Parent
(N
)));
9695 -- With the scope stack back to normal, we can call analyze on the
9696 -- resulting block. At this point, the transient scope is being
9697 -- treated like a perfectly normal scope, so there is nothing
9698 -- special about it.
9700 -- Note: Wrap_Transient_Statement is called with the node already
9701 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9702 -- otherwise we would get a recursive processing of the node when
9703 -- we do this Analyze call.
9706 end Wrap_Transient_Statement
;