1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Einfo
.Entities
; use Einfo
.Entities
;
34 with Einfo
.Utils
; use Einfo
.Utils
;
35 with Elists
; use Elists
;
36 with Errout
; use Errout
;
37 with Exp_Ch6
; use Exp_Ch6
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Ch11
; use Exp_Ch11
;
40 with Exp_Dbug
; use Exp_Dbug
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Disp
; use Exp_Disp
;
43 with Exp_Prag
; use Exp_Prag
;
44 with Exp_Tss
; use Exp_Tss
;
45 with Exp_Util
; use Exp_Util
;
46 with Freeze
; use Freeze
;
47 with GNAT_CUDA
; use GNAT_CUDA
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
52 with Output
; use Output
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
58 with Sinfo
.Utils
; use Sinfo
.Utils
;
60 with Sem_Aux
; use Sem_Aux
;
61 with Sem_Ch7
; use Sem_Ch7
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Snames
; use Snames
;
66 with Stand
; use Stand
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Uintp
; use Uintp
;
71 package body Exp_Ch7
is
73 --------------------------------
74 -- Transient Scope Management --
75 --------------------------------
77 -- A transient scope is needed when certain temporary objects are created
78 -- by the compiler. These temporary objects are allocated on the secondary
79 -- stack and/or need finalization, and the transient scope is responsible
80 -- for finalizing the objects and reclaiming the memory of the secondary
81 -- stack at the appropriate time. They are generally objects allocated to
82 -- store the result of a function returning an unconstrained or controlled
83 -- value. Expressions needing to be wrapped in a transient scope may appear
84 -- in three different contexts which lead to different kinds of transient
87 -- 1. In a simple statement (procedure call, assignment, ...). In this
88 -- case the instruction is wrapped into a transient block. See
89 -- Wrap_Transient_Statement for details.
91 -- 2. In an expression of a control structure (test in a IF statement,
92 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
95 -- 3. In a expression of an object_declaration. No wrapping is possible
96 -- here, so the finalization actions, if any, are done right after the
97 -- declaration and the secondary stack deallocation is done in the
98 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
100 --------------------------------------------------
101 -- Transient Blocks and Finalization Management --
102 --------------------------------------------------
104 procedure Insert_Actions_In_Scope_Around
107 Manage_SS
: Boolean);
108 -- Insert the before-actions kept in the scope stack before N, and the
109 -- after-actions after N, which must be a member of a list. If flag Clean
110 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
111 -- calls to mark and release the secondary stack.
113 function Make_Transient_Block
116 Par
: Node_Id
) return Node_Id
;
117 -- Action is a single statement or object declaration. Par is the proper
118 -- parent of the generated block. Create a transient block whose name is
119 -- the current scope and the only handled statement is Action. If Action
120 -- involves controlled objects or secondary stack usage, the corresponding
121 -- cleanup actions are performed at the end of the block.
123 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
124 -- Shared processing for Store_xxx_Actions_In_Scope
126 -----------------------------
127 -- Finalization Management --
128 -----------------------------
130 -- This part describes how Initialization/Adjustment/Finalization
131 -- procedures are generated and called. Two cases must be considered: types
132 -- that are Controlled (Is_Controlled flag set) and composite types that
133 -- contain controlled components (Has_Controlled_Component flag set). In
134 -- the first case the procedures to call are the user-defined primitive
135 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
136 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
137 -- charge of calling the former procedures on the controlled components.
139 -- For records with Has_Controlled_Component set, a hidden "controller"
140 -- component is inserted. This controller component contains its own
141 -- finalization list on which all controlled components are attached
142 -- creating an indirection on the upper-level Finalization list. This
143 -- technique facilitates the management of objects whose number of
144 -- controlled components changes during execution. This controller
145 -- component is itself controlled and is attached to the upper-level
146 -- finalization chain. Its adjust primitive is in charge of calling adjust
147 -- on the components and adjusting the finalization pointer to match their
148 -- new location (see a-finali.adb).
150 -- It is not possible to use a similar technique for arrays that have
151 -- Has_Controlled_Component set. In this case, deep procedures are
152 -- generated that call initialize/adjust/finalize + attachment or
153 -- detachment on the finalization list for all component.
155 -- Initialize calls: they are generated for declarations or dynamic
156 -- allocations of Controlled objects with no initial value. They are always
157 -- followed by an attachment to the current Finalization Chain. For the
158 -- dynamic allocation case this the chain attached to the scope of the
159 -- access type definition otherwise, this is the chain of the current
162 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
163 -- or dynamic allocations of Controlled objects with an initial value.
164 -- (2) after an assignment. In the first case they are followed by an
165 -- attachment to the final chain, in the second case they are not.
167 -- Finalization Calls: They are generated on (1) scope exit, (2)
168 -- assignments, (3) unchecked deallocations. In case (3) they have to
169 -- be detached from the final chain, in case (2) they must not and in
170 -- case (1) this is not important since we are exiting the scope anyway.
174 -- Type extensions will have a new record controller at each derivation
175 -- level containing controlled components. The record controller for
176 -- the parent/ancestor is attached to the finalization list of the
177 -- extension's record controller (i.e. the parent is like a component
178 -- of the extension).
180 -- For types that are both Is_Controlled and Has_Controlled_Components,
181 -- the record controller and the object itself are handled separately.
182 -- It could seem simpler to attach the object at the end of its record
183 -- controller but this would not tackle view conversions properly.
185 -- A classwide type can always potentially have controlled components
186 -- but the record controller of the corresponding actual type may not
187 -- be known at compile time so the dispatch table contains a special
188 -- field that allows computation of the offset of the record controller
189 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
191 -- Here is a simple example of the expansion of a controlled block :
195 -- Y : Controlled := Init;
201 -- Z : R := (C => X);
211 -- _L : System.FI.Finalizable_Ptr;
213 -- procedure _Clean is
216 -- System.FI.Finalize_List (_L);
224 -- Attach_To_Final_List (_L, Finalizable (X), 1);
225 -- at end: Abort_Undefer;
226 -- Y : Controlled := Init;
228 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
236 -- Deep_Initialize (W, _L, 1);
237 -- at end: Abort_Under;
238 -- Z : R := (C => X);
239 -- Deep_Adjust (Z, _L, 1);
243 -- Deep_Finalize (W, False);
244 -- <save W's final pointers>
246 -- <restore W's final pointers>
247 -- Deep_Adjust (W, _L, 0);
252 type Final_Primitives
is
253 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
254 -- This enumeration type is defined in order to ease sharing code for
255 -- building finalization procedures for composite types.
257 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
258 (Initialize_Case
=> Name_Initialize
,
259 Adjust_Case
=> Name_Adjust
,
260 Finalize_Case
=> Name_Finalize
,
261 Address_Case
=> Name_Finalize_Address
);
262 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
263 (Initialize_Case
=> TSS_Deep_Initialize
,
264 Adjust_Case
=> TSS_Deep_Adjust
,
265 Finalize_Case
=> TSS_Deep_Finalize
,
266 Address_Case
=> TSS_Finalize_Address
);
268 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
269 -- Determine whether access type Typ may have a finalization master
271 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
272 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
273 -- Has_Controlled_Component set and store them using the TSS mechanism.
275 function Build_Cleanup_Statements
277 Additional_Cleanup
: List_Id
) return List_Id
;
278 -- Create the cleanup calls for an asynchronous call block, task master,
279 -- protected subprogram body, task allocation block or task body, or
280 -- additional cleanup actions parked on a transient block. If the context
281 -- does not contain the above constructs, the routine returns an empty
284 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
285 -- N is a construct that contains a handled sequence of statements, Fin_Id
286 -- is the entity of a finalizer. Create an At_End handler that covers the
287 -- statements of N and calls Fin_Id. If the handled statement sequence has
288 -- an exception handler, the statements will be wrapped in a block to avoid
289 -- unwanted interaction with the new At_End handler.
291 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
292 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
293 -- Has_Component_Component set and store them using the TSS mechanism.
295 -------------------------------------------
296 -- Unnesting procedures for CCG and LLVM --
297 -------------------------------------------
299 -- Expansion generates subprograms for controlled types management that
300 -- may appear in declarative lists in package declarations and bodies.
301 -- These subprograms appear within generated blocks that contain local
302 -- declarations and a call to finalization procedures. To ensure that
303 -- such subprograms get activation records when needed, we transform the
304 -- block into a procedure body, followed by a call to it in the same
307 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
);
308 -- The statement part of a package body that is a compilation unit may
309 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
310 -- Mode such subprograms must be handled as nested inside the (implicit)
311 -- elaboration procedure that executes that statement part. To handle
312 -- properly uplevel references we construct that subprogram explicitly,
313 -- to contain blocks and inner subprograms, the statement part becomes
314 -- a call to this subprogram. This is only done if blocks are present
315 -- in the statement list of the body. (It would be nice to unify this
316 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
317 -- they're doing very similar work, but are structured differently. ???)
319 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
);
320 -- Similarly, the declarations or statements in library-level packages may
321 -- have created blocks with nested subprograms. Such a block must be
322 -- transformed into a procedure followed by a call to it, so that unnesting
323 -- can handle uplevel references within these nested subprograms (typically
324 -- subprograms that handle finalization actions). This also applies to
325 -- nested packages, including instantiations, in which case it must
326 -- recursively process inner bodies.
328 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
);
329 -- Similarly, check for blocks with nested subprograms occurring within
330 -- a set of exception handlers associated with a package body N.
332 procedure Unnest_Block
(Decl
: Node_Id
);
333 -- Blocks that contain nested subprograms with up-level references need to
334 -- create activation records for them. We do this by rewriting the block as
335 -- a procedure, followed by a call to it in the same declarative list, to
336 -- replicate the semantics of the original block.
338 -- A common source for such block is a transient block created for a
339 -- construct (declaration, assignment, etc.) that involves controlled
340 -- actions or secondary-stack management, in which case the nested
341 -- subprogram is a finalizer.
343 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
);
344 -- The separate statement lists associated with an if-statement (then part,
345 -- elsif parts, else part) may require unnesting if they directly contain
346 -- a subprogram body that references up-level objects. Each statement list
347 -- is traversed to locate such subprogram bodies, and if a part's statement
348 -- list contains a body, then the list is replaced with a new procedure
349 -- containing the part's statements followed by a call to the procedure.
350 -- Furthermore, any nested blocks, loops, or if statements will also be
351 -- traversed to determine the need for further unnesting transformations.
353 procedure Unnest_Statement_List
(Stmts
: in out List_Id
);
354 -- A list of statements that directly contains a subprogram at its outer
355 -- level, that may reference objects declared in that same statement list,
356 -- is rewritten as a procedure containing the statement list Stmts (which
357 -- includes any such objects as well as the nested subprogram), followed by
358 -- a call to the new procedure, and Stmts becomes the list containing the
359 -- procedure and the call. This ensures that Unnest_Subprogram will later
360 -- properly handle up-level references from the nested subprogram to
361 -- objects declared earlier in statement list, by creating an activation
362 -- record and passing it to the nested subprogram. This procedure also
363 -- resets the Scope of objects declared in the statement list, as well as
364 -- the Scope of the nested subprogram, to refer to the new procedure.
365 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
366 -- only be called when known that the statement list contains a subprogram.
368 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
);
369 -- Top-level Loops that contain nested subprograms with up-level references
370 -- need to have activation records. We do this by rewriting the loop as a
371 -- procedure containing the loop, followed by a call to the procedure in
372 -- the same library-level declarative list, to replicate the semantics of
373 -- the original loop. Such loops can occur due to aggregate expansions and
376 procedure Check_Visibly_Controlled
377 (Prim
: Final_Primitives
;
379 E
: in out Entity_Id
;
380 Cref
: in out Node_Id
);
381 -- The controlled operation declared for a derived type may not be
382 -- overriding, if the controlled operations of the parent type are hidden,
383 -- for example when the parent is a private type whose full view is
384 -- controlled. For other primitive operations we modify the name of the
385 -- operation to indicate that it is not overriding, but this is not
386 -- possible for Initialize, etc. because they have to be retrievable by
387 -- name. Before generating the proper call to one of these operations we
388 -- check whether Typ is known to be controlled at the point of definition.
389 -- If it is not then we must retrieve the hidden operation of the parent
390 -- and use it instead. This is one case that might be solved more cleanly
391 -- once Overriding pragmas or declarations are in place.
393 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean;
394 -- Check recursively whether a loop or block contains a subprogram that
395 -- may need an activation record.
397 function Convert_View
(Proc
: Entity_Id
; Arg
: Node_Id
) return Node_Id
;
398 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
399 -- argument being passed to it. This function will, if necessary, generate
400 -- a conversion between the partial and full view of Arg to match the type
401 -- of the formal of Proc, or force a conversion to the class-wide type in
402 -- the case where the operation is abstract.
408 Skip_Self
: Boolean := False) return Node_Id
;
409 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
410 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
411 -- an adjust or finalization call. When flag Skip_Self is set, the related
412 -- action has an effect on the components only (if any).
414 function Make_Deep_Proc
415 (Prim
: Final_Primitives
;
417 Stmts
: List_Id
) return Entity_Id
;
418 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
419 -- Deep_Finalize procedures according to the first parameter. These
420 -- procedures operate on the type Typ. The Stmts parameter gives the
421 -- body of the procedure.
423 function Make_Deep_Array_Body
424 (Prim
: Final_Primitives
;
425 Typ
: Entity_Id
) return List_Id
;
426 -- This function generates the list of statements for implementing
427 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
428 -- the first parameter, these procedures operate on the array type Typ.
430 function Make_Deep_Record_Body
431 (Prim
: Final_Primitives
;
433 Is_Local
: Boolean := False) return List_Id
;
434 -- This function generates the list of statements for implementing
435 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
436 -- the first parameter, these procedures operate on the record type Typ.
437 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
438 -- whether the inner logic should be dictated by state counters.
440 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
441 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
442 -- Make_Deep_Record_Body. Generate the following statements:
445 -- type Acc_Typ is access all Typ;
446 -- for Acc_Typ'Storage_Size use 0;
448 -- [Deep_]Finalize (Acc_Typ (V).all);
451 --------------------------------
452 -- Allows_Finalization_Master --
453 --------------------------------
455 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
456 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
457 -- Determine whether entity E is inside a wrapper package created for
458 -- an instance of Ada.Unchecked_Deallocation.
460 ------------------------------
461 -- In_Deallocation_Instance --
462 ------------------------------
464 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
465 Pkg
: constant Entity_Id
:= Scope
(E
);
466 Par
: Node_Id
:= Empty
;
469 if Ekind
(Pkg
) = E_Package
470 and then Present
(Related_Instance
(Pkg
))
471 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
473 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
477 and then Chars
(Par
) = Name_Unchecked_Deallocation
478 and then Chars
(Scope
(Par
)) = Name_Ada
479 and then Scope
(Scope
(Par
)) = Standard_Standard
;
483 end In_Deallocation_Instance
;
487 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
488 Ptr_Typ
: constant Entity_Id
:=
489 Root_Type_Of_Full_View
(Base_Type
(Typ
));
491 -- Start of processing for Allows_Finalization_Master
494 -- Certain run-time configurations and targets do not provide support
495 -- for controlled types and therefore do not need masters.
497 if Restriction_Active
(No_Finalization
) then
500 -- Do not consider C and C++ types since it is assumed that the non-Ada
501 -- side will handle their cleanup.
503 elsif Convention
(Desig_Typ
) = Convention_C
504 or else Convention
(Desig_Typ
) = Convention_CPP
508 -- Do not consider an access type that returns on the secondary stack
510 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
511 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
515 -- Do not consider an access type that can never allocate an object
517 elsif No_Pool_Assigned
(Ptr_Typ
) then
520 -- Do not consider an access type coming from an Unchecked_Deallocation
521 -- instance. Even though the designated type may be controlled, the
522 -- access type will never participate in any allocations.
524 elsif In_Deallocation_Instance
(Ptr_Typ
) then
527 -- Do not consider a non-library access type when No_Nested_Finalization
528 -- is in effect since finalization masters are controlled objects and if
529 -- created will violate the restriction.
531 elsif Restriction_Active
(No_Nested_Finalization
)
532 and then not Is_Library_Level_Entity
(Ptr_Typ
)
536 -- Do not consider an access type subject to pragma No_Heap_Finalization
537 -- because objects allocated through such a type are not to be finalized
538 -- when the access type goes out of scope.
540 elsif No_Heap_Finalization
(Ptr_Typ
) then
543 -- Do not create finalization masters in GNATprove mode because this
544 -- causes unwanted extra expansion. A compilation in this mode must
545 -- keep the tree as close as possible to the original sources.
547 elsif GNATprove_Mode
then
550 -- Otherwise the access type may use a finalization master
555 end Allows_Finalization_Master
;
557 ----------------------------
558 -- Build_Anonymous_Master --
559 ----------------------------
561 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
562 function Create_Anonymous_Master
563 (Desig_Typ
: Entity_Id
;
565 Unit_Decl
: Node_Id
) return Entity_Id
;
566 -- Create a new anonymous master for access type Ptr_Typ with designated
567 -- type Desig_Typ. The declaration of the master and its initialization
568 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
569 -- the entity of Unit_Decl.
571 function Current_Anonymous_Master
572 (Desig_Typ
: Entity_Id
;
573 Unit_Id
: Entity_Id
) return Entity_Id
;
574 -- Find an anonymous master declared within unit Unit_Id which services
575 -- designated type Desig_Typ. If there is no such master, return Empty.
577 -----------------------------
578 -- Create_Anonymous_Master --
579 -----------------------------
581 function Create_Anonymous_Master
582 (Desig_Typ
: Entity_Id
;
584 Unit_Decl
: Node_Id
) return Entity_Id
586 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
597 -- <FM_Id> : Finalization_Master;
599 FM_Id
:= Make_Temporary
(Loc
, 'A');
602 Make_Object_Declaration
(Loc
,
603 Defining_Identifier
=> FM_Id
,
605 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
609 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
612 Make_Procedure_Call_Statement
(Loc
,
614 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
615 Parameter_Associations
=> New_List
(
616 New_Occurrence_Of
(FM_Id
, Loc
),
617 Make_Attribute_Reference
(Loc
,
619 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
620 Attribute_Name
=> Name_Unrestricted_Access
)));
622 -- Find the declarative list of the unit
624 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
625 Unit_Spec
:= Specification
(Unit_Decl
);
626 Decls
:= Visible_Declarations
(Unit_Spec
);
630 Set_Visible_Declarations
(Unit_Spec
, Decls
);
633 -- Package body or subprogram case
635 -- ??? A subprogram spec or body that acts as a compilation unit may
636 -- contain a formal parameter of an anonymous access-to-controlled
637 -- type initialized by an allocator.
639 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
641 -- There is no suitable place to create the master as the subprogram
642 -- is not in a declarative list.
645 Decls
:= Declarations
(Unit_Decl
);
649 Set_Declarations
(Unit_Decl
, Decls
);
653 Prepend_To
(Decls
, FM_Init
);
654 Prepend_To
(Decls
, FM_Decl
);
656 -- Use the scope of the unit when analyzing the declaration of the
657 -- master and its initialization actions.
659 Push_Scope
(Unit_Id
);
664 -- Mark the master as servicing this specific designated type
666 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
668 -- Include the anonymous master in the list of existing masters which
669 -- appear in this unit. This effectively creates a mapping between a
670 -- master and a designated type which in turn allows for the reuse of
671 -- masters on a per-unit basis.
673 All_FMs
:= Anonymous_Masters
(Unit_Id
);
676 All_FMs
:= New_Elmt_List
;
677 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
680 Prepend_Elmt
(FM_Id
, All_FMs
);
683 end Create_Anonymous_Master
;
685 ------------------------------
686 -- Current_Anonymous_Master --
687 ------------------------------
689 function Current_Anonymous_Master
690 (Desig_Typ
: Entity_Id
;
691 Unit_Id
: Entity_Id
) return Entity_Id
693 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
698 -- Inspect the list of anonymous masters declared within the unit
699 -- looking for an existing master which services the same designated
702 if Present
(All_FMs
) then
703 FM_Elmt
:= First_Elmt
(All_FMs
);
704 while Present
(FM_Elmt
) loop
705 FM_Id
:= Node
(FM_Elmt
);
707 -- The currect master services the same designated type. As a
708 -- result the master can be reused and associated with another
709 -- anonymous access-to-controlled type.
711 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
720 end Current_Anonymous_Master
;
724 Desig_Typ
: Entity_Id
;
726 Priv_View
: Entity_Id
;
730 -- Start of processing for Build_Anonymous_Master
733 -- Nothing to do if the circumstances do not allow for a finalization
736 if not Allows_Finalization_Master
(Ptr_Typ
) then
740 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
741 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
743 -- The compilation unit is a package instantiation. In this case the
744 -- anonymous master is associated with the package spec as both the
745 -- spec and body appear at the same level.
747 if Nkind
(Unit_Decl
) = N_Package_Body
748 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
750 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
751 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
754 -- Use the initial declaration of the designated type when it denotes
755 -- the full view of an incomplete or private type. This ensures that
756 -- types with one and two views are treated the same.
758 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
759 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
761 if Present
(Priv_View
) then
762 Desig_Typ
:= Priv_View
;
765 -- Determine whether the current semantic unit already has an anonymous
766 -- master which services the designated type.
768 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
770 -- If this is not the case, create a new master
773 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
776 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
777 end Build_Anonymous_Master
;
779 ----------------------------
780 -- Build_Array_Deep_Procs --
781 ----------------------------
783 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
787 (Prim
=> Initialize_Case
,
789 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
791 if not Is_Limited_View
(Typ
) then
794 (Prim
=> Adjust_Case
,
796 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
799 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
800 -- suppressed since these routine will not be used.
802 if not Restriction_Active
(No_Finalization
) then
805 (Prim
=> Finalize_Case
,
807 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
809 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
811 if not CodePeer_Mode
then
814 (Prim
=> Address_Case
,
816 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
819 end Build_Array_Deep_Procs
;
821 ------------------------------
822 -- Build_Cleanup_Statements --
823 ------------------------------
825 function Build_Cleanup_Statements
827 Additional_Cleanup
: List_Id
) return List_Id
829 Is_Asynchronous_Call
: constant Boolean :=
830 Nkind
(N
) = N_Block_Statement
and then Is_Asynchronous_Call_Block
(N
);
831 Is_Master
: constant Boolean :=
832 Nkind
(N
) /= N_Entry_Body
and then Is_Task_Master
(N
);
833 Is_Protected_Subp_Body
: constant Boolean :=
834 Nkind
(N
) = N_Subprogram_Body
835 and then Is_Protected_Subprogram_Body
(N
);
836 Is_Task_Allocation
: constant Boolean :=
837 Nkind
(N
) = N_Block_Statement
and then Is_Task_Allocation_Block
(N
);
838 Is_Task_Body
: constant Boolean :=
839 Nkind
(Original_Node
(N
)) = N_Task_Body
;
841 Loc
: constant Source_Ptr
:= Sloc
(N
);
842 Stmts
: constant List_Id
:= New_List
;
846 if Restricted_Profile
then
848 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
850 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
854 if Restriction_Active
(No_Task_Hierarchy
) = False then
855 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
858 -- Add statements to unlock the protected object parameter and to
859 -- undefer abort. If the context is a protected procedure and the object
860 -- has entries, call the entry service routine.
862 -- NOTE: The generated code references _object, a parameter to the
865 elsif Is_Protected_Subp_Body
then
867 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
868 Conc_Typ
: Entity_Id
:= Empty
;
870 Param_Typ
: Entity_Id
;
873 -- Find the _object parameter representing the protected object
875 Param
:= First
(Parameter_Specifications
(Spec
));
877 Param_Typ
:= Etype
(Parameter_Type
(Param
));
879 if Ekind
(Param_Typ
) = E_Record_Type
then
880 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
883 exit when No
(Param
) or else Present
(Conc_Typ
);
887 pragma Assert
(Present
(Param
));
888 pragma Assert
(Present
(Conc_Typ
));
890 Build_Protected_Subprogram_Call_Cleanup
891 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
894 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
895 -- tasks. Other unactivated tasks are completed by Complete_Task or
898 -- NOTE: The generated code references _chain, a local object
900 elsif Is_Task_Allocation
then
903 -- Expunge_Unactivated_Tasks (_chain);
905 -- where _chain is the list of tasks created by the allocator but not
906 -- yet activated. This list will be empty unless the block completes
910 Make_Procedure_Call_Statement
(Loc
,
913 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
914 Parameter_Associations
=> New_List
(
915 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
917 -- Attempt to cancel an asynchronous entry call whenever the block which
918 -- contains the abortable part is exited.
920 -- NOTE: The generated code references Cnn, a local object
922 elsif Is_Asynchronous_Call
then
924 Cancel_Param
: constant Entity_Id
:=
925 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
928 -- If it is of type Communication_Block, this must be a protected
929 -- entry call. Generate:
931 -- if Enqueued (Cancel_Param) then
932 -- Cancel_Protected_Entry_Call (Cancel_Param);
935 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
937 Make_If_Statement
(Loc
,
939 Make_Function_Call
(Loc
,
941 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
942 Parameter_Associations
=> New_List
(
943 New_Occurrence_Of
(Cancel_Param
, Loc
))),
945 Then_Statements
=> New_List
(
946 Make_Procedure_Call_Statement
(Loc
,
949 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
950 Parameter_Associations
=> New_List
(
951 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
953 -- Asynchronous delay, generate:
954 -- Cancel_Async_Delay (Cancel_Param);
956 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
958 Make_Procedure_Call_Statement
(Loc
,
960 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
961 Parameter_Associations
=> New_List
(
962 Make_Attribute_Reference
(Loc
,
964 New_Occurrence_Of
(Cancel_Param
, Loc
),
965 Attribute_Name
=> Name_Unchecked_Access
))));
967 -- Task entry call, generate:
968 -- Cancel_Task_Entry_Call (Cancel_Param);
972 Make_Procedure_Call_Statement
(Loc
,
974 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
975 Parameter_Associations
=> New_List
(
976 New_Occurrence_Of
(Cancel_Param
, Loc
))));
981 Append_List_To
(Stmts
, Additional_Cleanup
);
983 end Build_Cleanup_Statements
;
985 -----------------------------
986 -- Build_Controlling_Procs --
987 -----------------------------
989 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
991 if Is_Array_Type
(Typ
) then
992 Build_Array_Deep_Procs
(Typ
);
993 else pragma Assert
(Is_Record_Type
(Typ
));
994 Build_Record_Deep_Procs
(Typ
);
996 end Build_Controlling_Procs
;
998 -----------------------------
999 -- Build_Exception_Handler --
1000 -----------------------------
1002 function Build_Exception_Handler
1003 (Data
: Finalization_Exception_Data
;
1004 For_Library
: Boolean := False) return Node_Id
1007 Proc_To_Call
: Entity_Id
;
1012 pragma Assert
(Present
(Data
.Raised_Id
));
1014 if Exception_Extra_Info
1015 or else (For_Library
and not Restricted_Profile
)
1017 if Exception_Extra_Info
then
1021 -- Get_Current_Excep.all
1024 Make_Function_Call
(Data
.Loc
,
1026 Make_Explicit_Dereference
(Data
.Loc
,
1029 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1036 Except
:= Make_Null
(Data
.Loc
);
1039 if For_Library
and then not Restricted_Profile
then
1040 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1041 Actuals
:= New_List
(Except
);
1044 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1046 -- The dereference occurs only when Exception_Extra_Info is true,
1047 -- and therefore Except is not null.
1051 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1052 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1058 -- if not Raised_Id then
1059 -- Raised_Id := True;
1061 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1063 -- Save_Library_Occurrence (Get_Current_Excep.all);
1068 Make_If_Statement
(Data
.Loc
,
1070 Make_Op_Not
(Data
.Loc
,
1071 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1073 Then_Statements
=> New_List
(
1074 Make_Assignment_Statement
(Data
.Loc
,
1075 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1076 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1078 Make_Procedure_Call_Statement
(Data
.Loc
,
1080 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1081 Parameter_Associations
=> Actuals
))));
1086 -- Raised_Id := True;
1089 Make_Assignment_Statement
(Data
.Loc
,
1090 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1091 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1099 Make_Exception_Handler
(Data
.Loc
,
1100 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1101 Statements
=> Stmts
);
1102 end Build_Exception_Handler
;
1104 -------------------------------
1105 -- Build_Finalization_Master --
1106 -------------------------------
1108 procedure Build_Finalization_Master
1110 For_Lib_Level
: Boolean := False;
1111 For_Private
: Boolean := False;
1112 Context_Scope
: Entity_Id
:= Empty
;
1113 Insertion_Node
: Node_Id
:= Empty
)
1115 procedure Add_Pending_Access_Type
1117 Ptr_Typ
: Entity_Id
);
1118 -- Add access type Ptr_Typ to the pending access type list for type Typ
1120 -----------------------------
1121 -- Add_Pending_Access_Type --
1122 -----------------------------
1124 procedure Add_Pending_Access_Type
1126 Ptr_Typ
: Entity_Id
)
1131 if Present
(Pending_Access_Types
(Typ
)) then
1132 List
:= Pending_Access_Types
(Typ
);
1134 List
:= New_Elmt_List
;
1135 Set_Pending_Access_Types
(Typ
, List
);
1138 Prepend_Elmt
(Ptr_Typ
, List
);
1139 end Add_Pending_Access_Type
;
1143 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1145 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1146 -- A finalization master created for a named access type is associated
1147 -- with the full view (if applicable) as a consequence of freezing. The
1148 -- full view criteria does not apply to anonymous access types because
1149 -- those cannot have a private and a full view.
1151 -- Start of processing for Build_Finalization_Master
1154 -- Nothing to do if the circumstances do not allow for a finalization
1157 if not Allows_Finalization_Master
(Typ
) then
1160 -- Various machinery such as freezing may have already created a
1161 -- finalization master.
1163 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1168 Actions
: constant List_Id
:= New_List
;
1169 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1170 Fin_Mas_Id
: Entity_Id
;
1171 Pool_Id
: Entity_Id
;
1174 -- Source access types use fixed master names since the master is
1175 -- inserted in the same source unit only once. The only exception to
1176 -- this are instances using the same access type as generic actual.
1178 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1180 Make_Defining_Identifier
(Loc
,
1181 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1183 -- Internally generated access types use temporaries as their names
1184 -- due to possible collision with identical names coming from other
1188 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1191 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1194 -- <Ptr_Typ>FM : aliased Finalization_Master;
1197 Make_Object_Declaration
(Loc
,
1198 Defining_Identifier
=> Fin_Mas_Id
,
1199 Aliased_Present
=> True,
1200 Object_Definition
=>
1201 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1203 if Debug_Generated_Code
then
1204 Set_Debug_Info_Needed
(Fin_Mas_Id
);
1207 -- Set the associated pool and primitive Finalize_Address of the new
1208 -- finalization master.
1210 -- The access type has a user-defined storage pool, use it
1212 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1213 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1215 -- Otherwise the default choice is the global storage pool
1218 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1219 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1223 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1226 Make_Procedure_Call_Statement
(Loc
,
1228 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1229 Parameter_Associations
=> New_List
(
1230 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1231 Make_Attribute_Reference
(Loc
,
1232 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1233 Attribute_Name
=> Name_Unrestricted_Access
))));
1235 -- Finalize_Address is not generated in CodePeer mode because the
1236 -- body contains address arithmetic. Skip this step.
1238 if CodePeer_Mode
then
1241 -- Associate the Finalize_Address primitive of the designated type
1242 -- with the finalization master of the access type. The designated
1243 -- type must be forzen as Finalize_Address is generated when the
1244 -- freeze node is expanded.
1246 elsif Is_Frozen
(Desig_Typ
)
1247 and then Present
(Finalize_Address
(Desig_Typ
))
1249 -- The finalization master of an anonymous access type may need
1250 -- to be inserted in a specific place in the tree. For instance:
1254 -- <finalization master of "access Comp_Typ">
1256 -- type Rec_Typ is record
1257 -- Comp : access Comp_Typ;
1260 -- <freeze node for Comp_Typ>
1261 -- <freeze node for Rec_Typ>
1263 -- Due to this oddity, the anonymous access type is stored for
1264 -- later processing (see below).
1266 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1269 -- Set_Finalize_Address
1270 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1273 Make_Set_Finalize_Address_Call
1275 Ptr_Typ
=> Ptr_Typ
));
1277 -- Otherwise the designated type is either anonymous access or a
1278 -- Taft-amendment type and has not been frozen. Store the access
1279 -- type for later processing (see Freeze_Type).
1282 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1285 -- A finalization master created for an access designating a type
1286 -- with private components is inserted before a context-dependent
1291 -- At this point both the scope of the context and the insertion
1292 -- mode must be known.
1294 pragma Assert
(Present
(Context_Scope
));
1295 pragma Assert
(Present
(Insertion_Node
));
1297 Push_Scope
(Context_Scope
);
1299 -- Treat use clauses as declarations and insert directly in front
1302 if Nkind
(Insertion_Node
) in
1303 N_Use_Package_Clause | N_Use_Type_Clause
1305 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1307 Insert_Actions
(Insertion_Node
, Actions
);
1312 -- The finalization master belongs to an access result type related
1313 -- to a build-in-place function call used to initialize a library
1314 -- level object. The master must be inserted in front of the access
1315 -- result type declaration denoted by Insertion_Node.
1317 elsif For_Lib_Level
then
1318 pragma Assert
(Present
(Insertion_Node
));
1319 Insert_Actions
(Insertion_Node
, Actions
);
1321 -- Otherwise the finalization master and its initialization become a
1322 -- part of the freeze node.
1325 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1328 Analyze_List
(Actions
);
1330 -- When the type the finalization master is being generated for was
1331 -- created to store a 'Old object, then mark it as such so its
1332 -- finalization can be delayed until after postconditions have been
1335 if Stores_Attribute_Old_Prefix
(Ptr_Typ
) then
1336 Set_Stores_Attribute_Old_Prefix
(Fin_Mas_Id
);
1339 end Build_Finalization_Master
;
1341 ---------------------
1342 -- Build_Finalizer --
1343 ---------------------
1345 procedure Build_Finalizer
1347 Clean_Stmts
: List_Id
;
1348 Mark_Id
: Entity_Id
;
1349 Top_Decls
: List_Id
;
1350 Defer_Abort
: Boolean;
1351 Fin_Id
: out Entity_Id
)
1353 Acts_As_Clean
: constant Boolean :=
1356 (Present
(Clean_Stmts
)
1357 and then Is_Non_Empty_List
(Clean_Stmts
));
1359 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1360 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1361 For_Package
: constant Boolean :=
1362 For_Package_Body
or else For_Package_Spec
;
1363 Loc
: constant Source_Ptr
:= Sloc
(N
);
1365 -- NOTE: Local variable declarations are conservative and do not create
1366 -- structures right from the start. Entities and lists are created once
1367 -- it has been established that N has at least one controlled object.
1369 Components_Built
: Boolean := False;
1370 -- A flag used to avoid double initialization of entities and lists. If
1371 -- the flag is set then the following variables have been initialized:
1377 Counter_Id
: Entity_Id
:= Empty
;
1378 Counter_Val
: Nat
:= 0;
1379 -- Name and value of the state counter
1381 Decls
: List_Id
:= No_List
;
1382 -- Declarative region of N (if available). If N is a package declaration
1383 -- Decls denotes the visible declarations.
1385 Finalizer_Data
: Finalization_Exception_Data
;
1386 -- Data for the exception
1388 Finalizer_Decls
: List_Id
:= No_List
;
1389 -- Local variable declarations. This list holds the label declarations
1390 -- of all jump block alternatives as well as the declaration of the
1391 -- local exception occurrence and the raised flag:
1392 -- E : Exception_Occurrence;
1393 -- Raised : Boolean := False;
1394 -- L<counter value> : label;
1396 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1397 -- Insertion point for the finalizer body. Depending on the context
1398 -- (Nkind of N) and the individual grouping of controlled objects, this
1399 -- node may denote a package declaration or body, package instantiation,
1400 -- block statement or a counter update statement.
1402 Finalizer_Stmts
: List_Id
:= No_List
;
1403 -- The statement list of the finalizer body. It contains the following:
1405 -- Abort_Defer; -- Added if abort is allowed
1406 -- <call to Prev_At_End> -- Added if exists
1407 -- <cleanup statements> -- Added if Acts_As_Clean
1408 -- <jump block> -- Added if Has_Ctrl_Objs
1409 -- <finalization statements> -- Added if Has_Ctrl_Objs
1410 -- <stack release> -- Added if Mark_Id exists
1411 -- Abort_Undefer; -- Added if abort is allowed
1413 Has_Ctrl_Objs
: Boolean := False;
1414 -- A general flag which denotes whether N has at least one controlled
1417 Has_Tagged_Types
: Boolean := False;
1418 -- A general flag which indicates whether N has at least one library-
1419 -- level tagged type declaration.
1421 HSS
: Node_Id
:= Empty
;
1422 -- The sequence of statements of N (if available)
1424 Jump_Alts
: List_Id
:= No_List
;
1425 -- Jump block alternatives. Depending on the value of the state counter,
1426 -- the control flow jumps to a sequence of finalization statements. This
1427 -- list contains the following:
1429 -- when <counter value> =>
1430 -- goto L<counter value>;
1432 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1433 -- Specific point in the finalizer statements where the jump block is
1436 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1437 -- The last controlled construct encountered when processing the top
1438 -- level lists of N. This can be a nested package, an instantiation or
1439 -- an object declaration.
1441 Prev_At_End
: Entity_Id
:= Empty
;
1442 -- The previous at end procedure of the handled statements block of N
1444 Priv_Decls
: List_Id
:= No_List
;
1445 -- The private declarations of N if N is a package declaration
1447 Spec_Id
: Entity_Id
:= Empty
;
1448 Spec_Decls
: List_Id
:= Top_Decls
;
1449 Stmts
: List_Id
:= No_List
;
1451 Tagged_Type_Stmts
: List_Id
:= No_List
;
1452 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1453 -- tagged types found in N.
1455 -----------------------
1456 -- Local subprograms --
1457 -----------------------
1459 procedure Build_Components
;
1460 -- Create all entites and initialize all lists used in the creation of
1463 procedure Create_Finalizer
;
1464 -- Create the spec and body of the finalizer and insert them in the
1465 -- proper place in the tree depending on the context.
1467 function New_Finalizer_Name
1468 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
;
1469 -- Create a fully qualified name of a package spec or body finalizer.
1470 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1472 procedure Process_Declarations
1474 Preprocess
: Boolean := False;
1475 Top_Level
: Boolean := False);
1476 -- Inspect a list of declarations or statements which may contain
1477 -- objects that need finalization. When flag Preprocess is set, the
1478 -- routine will simply count the total number of controlled objects in
1479 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1480 -- when Preprocess is set and if True, the processing is performed for
1481 -- objects in nested package declarations or instances.
1483 procedure Process_Object_Declaration
1485 Has_No_Init
: Boolean := False;
1486 Is_Protected
: Boolean := False);
1487 -- Generate all the machinery associated with the finalization of a
1488 -- single object. Flag Has_No_Init is used to denote certain contexts
1489 -- where Decl does not have initialization call(s). Flag Is_Protected
1490 -- is set when Decl denotes a simple protected object.
1492 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1493 -- Generate all the code necessary to unregister the external tag of a
1496 ----------------------
1497 -- Build_Components --
1498 ----------------------
1500 procedure Build_Components
is
1501 Counter_Decl
: Node_Id
;
1502 Counter_Typ
: Entity_Id
;
1503 Counter_Typ_Decl
: Node_Id
;
1506 pragma Assert
(Present
(Decls
));
1508 -- This routine might be invoked several times when dealing with
1509 -- constructs that have two lists (either two declarative regions
1510 -- or declarations and statements). Avoid double initialization.
1512 if Components_Built
then
1516 Components_Built
:= True;
1518 if Has_Ctrl_Objs
then
1520 -- Create entities for the counter, its type, the local exception
1521 -- and the raised flag.
1523 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1524 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1526 Finalizer_Decls
:= New_List
;
1528 Build_Object_Declarations
1529 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1531 -- Since the total number of controlled objects is always known,
1532 -- build a subtype of Natural with precise bounds. This allows
1533 -- the backend to optimize the case statement. Generate:
1535 -- subtype Tnn is Natural range 0 .. Counter_Val;
1538 Make_Subtype_Declaration
(Loc
,
1539 Defining_Identifier
=> Counter_Typ
,
1540 Subtype_Indication
=>
1541 Make_Subtype_Indication
(Loc
,
1542 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1544 Make_Range_Constraint
(Loc
,
1548 Make_Integer_Literal
(Loc
, Uint_0
),
1550 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1552 -- Generate the declaration of the counter itself:
1554 -- Counter : Integer := 0;
1557 Make_Object_Declaration
(Loc
,
1558 Defining_Identifier
=> Counter_Id
,
1559 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1560 Expression
=> Make_Integer_Literal
(Loc
, 0));
1562 -- Set the type of the counter explicitly to prevent errors when
1563 -- examining object declarations later on.
1565 Set_Etype
(Counter_Id
, Counter_Typ
);
1567 if Debug_Generated_Code
then
1568 Set_Debug_Info_Needed
(Counter_Id
);
1571 -- The counter and its type are inserted before the source
1572 -- declarations of N.
1574 Prepend_To
(Decls
, Counter_Decl
);
1575 Prepend_To
(Decls
, Counter_Typ_Decl
);
1577 -- The counter and its associated type must be manually analyzed
1578 -- since N has already been analyzed. Use the scope of the spec
1579 -- when inserting in a package.
1582 Push_Scope
(Spec_Id
);
1583 Analyze
(Counter_Typ_Decl
);
1584 Analyze
(Counter_Decl
);
1588 Analyze
(Counter_Typ_Decl
);
1589 Analyze
(Counter_Decl
);
1592 Jump_Alts
:= New_List
;
1595 -- If the context requires additional cleanup, the finalization
1596 -- machinery is added after the cleanup code.
1598 if Acts_As_Clean
then
1599 Finalizer_Stmts
:= Clean_Stmts
;
1600 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1602 Finalizer_Stmts
:= New_List
;
1605 if Has_Tagged_Types
then
1606 Tagged_Type_Stmts
:= New_List
;
1608 end Build_Components
;
1610 ----------------------
1611 -- Create_Finalizer --
1612 ----------------------
1614 procedure Create_Finalizer
is
1615 Body_Id
: Entity_Id
;
1618 Jump_Block
: Node_Id
;
1620 Label_Id
: Entity_Id
;
1623 -- Step 1: Creation of the finalizer name
1625 -- Packages must use a distinct name for their finalizers since the
1626 -- binder will have to generate calls to them by name. The name is
1627 -- of the following form:
1629 -- xx__yy__finalize_[spec|body]
1632 Fin_Id
:= Make_Defining_Identifier
1633 (Loc
, New_Finalizer_Name
(Spec_Id
, For_Package_Spec
));
1634 Set_Has_Qualified_Name
(Fin_Id
);
1635 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1637 -- The default name is _finalizer
1640 -- Generation of a finalization procedure exclusively for 'Old
1641 -- interally generated constants requires different name since
1642 -- there will need to be multiple finalization routines in the
1643 -- same scope. See Build_Finalizer for details.
1646 Make_Defining_Identifier
(Loc
,
1647 Chars
=> New_External_Name
(Name_uFinalizer
));
1649 -- The visibility semantics of AT_END handlers force a strange
1650 -- separation of spec and body for stack-related finalizers:
1652 -- declare : Enclosing_Scope
1653 -- procedure _finalizer;
1655 -- <controlled objects>
1656 -- procedure _finalizer is
1662 -- Both spec and body are within the same construct and scope, but
1663 -- the body is part of the handled sequence of statements. This
1664 -- placement confuses the elaboration mechanism on targets where
1665 -- AT_END handlers are expanded into "when all others" handlers:
1668 -- when all others =>
1669 -- _finalizer; -- appears to require elab checks
1674 -- Since the compiler guarantees that the body of a _finalizer is
1675 -- always inserted in the same construct where the AT_END handler
1676 -- resides, there is no need for elaboration checks.
1678 Set_Kill_Elaboration_Checks
(Fin_Id
);
1680 -- Inlining the finalizer produces a substantial speedup at -O2.
1681 -- It is inlined by default at -O3. Either way, it is called
1682 -- exactly twice (once on the normal path, and once for
1683 -- exceptions/abort), so this won't bloat the code too much.
1685 Set_Is_Inlined
(Fin_Id
);
1688 if Debug_Generated_Code
then
1689 Set_Debug_Info_Needed
(Fin_Id
);
1692 -- Step 2: Creation of the finalizer specification
1695 -- procedure Fin_Id;
1698 Make_Subprogram_Declaration
(Loc
,
1700 Make_Procedure_Specification
(Loc
,
1701 Defining_Unit_Name
=> Fin_Id
));
1704 Set_Is_Exported
(Fin_Id
);
1705 Set_Interface_Name
(Fin_Id
,
1706 Make_String_Literal
(Loc
,
1707 Strval
=> Get_Name_String
(Chars
(Fin_Id
))));
1710 -- Step 3: Creation of the finalizer body
1712 -- Has_Ctrl_Objs might be set because of a generic package body having
1713 -- controlled objects. In this case, Jump_Alts may be empty and no
1714 -- case nor goto statements are needed.
1717 and then not Is_Empty_List
(Jump_Alts
)
1719 -- Add L0, the default destination to the jump block
1721 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1722 Set_Entity
(Label_Id
,
1723 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1724 Label
:= Make_Label
(Loc
, Label_Id
);
1729 Prepend_To
(Finalizer_Decls
,
1730 Make_Implicit_Label_Declaration
(Loc
,
1731 Defining_Identifier
=> Entity
(Label_Id
),
1732 Label_Construct
=> Label
));
1738 Append_To
(Jump_Alts
,
1739 Make_Case_Statement_Alternative
(Loc
,
1740 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1741 Statements
=> New_List
(
1742 Make_Goto_Statement
(Loc
,
1743 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1748 Append_To
(Finalizer_Stmts
, Label
);
1750 -- Create the jump block which controls the finalization flow
1751 -- depending on the value of the state counter.
1754 Make_Case_Statement
(Loc
,
1755 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1756 Alternatives
=> Jump_Alts
);
1758 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1759 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1761 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1765 -- Add the library-level tagged type unregistration machinery before
1766 -- the jump block circuitry. This ensures that external tags will be
1767 -- removed even if a finalization exception occurs at some point.
1769 if Has_Tagged_Types
then
1770 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1773 -- Add a call to the previous At_End handler if it exists. The call
1774 -- must always precede the jump block.
1776 if Present
(Prev_At_End
) then
1777 Prepend_To
(Finalizer_Stmts
,
1778 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1780 -- Clear the At_End handler since we have already generated the
1781 -- proper replacement call for it.
1783 Set_At_End_Proc
(HSS
, Empty
);
1786 -- Release the secondary stack
1788 if Present
(Mark_Id
) then
1790 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1793 -- If the context is a build-in-place function, the secondary
1794 -- stack must be released, unless the build-in-place function
1795 -- itself is returning on the secondary stack. Generate:
1797 -- if BIP_Alloc_Form /= Secondary_Stack then
1798 -- SS_Release (Mark_Id);
1801 -- Note that if the function returns on the secondary stack,
1802 -- then the responsibility of reclaiming the space is always
1803 -- left to the caller (recursively if needed).
1805 if Nkind
(N
) = N_Subprogram_Body
then
1807 Spec_Id
: constant Entity_Id
:=
1808 Unique_Defining_Entity
(N
);
1809 BIP_SS
: constant Boolean :=
1810 Is_Build_In_Place_Function
(Spec_Id
)
1811 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1815 Make_If_Statement
(Loc
,
1820 (Build_In_Place_Formal
1821 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1823 Make_Integer_Literal
(Loc
,
1825 (BIP_Allocation_Form
'Pos
1826 (Secondary_Stack
)))),
1828 Then_Statements
=> New_List
(Release
));
1833 Append_To
(Finalizer_Stmts
, Release
);
1837 -- Protect the statements with abort defer/undefer. This is only when
1838 -- aborts are allowed and the cleanup statements require deferral or
1839 -- there are controlled objects to be finalized. Note that the abort
1840 -- defer/undefer pair does not require an extra block because each
1841 -- finalization exception is caught in its corresponding finalization
1842 -- block. As a result, the call to Abort_Defer always takes place.
1844 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1845 Prepend_To
(Finalizer_Stmts
,
1846 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1848 Append_To
(Finalizer_Stmts
,
1849 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1852 -- The local exception does not need to be reraised for library-level
1853 -- finalizers. Note that this action must be carried out after object
1854 -- cleanup, secondary stack release, and abort undeferral. Generate:
1856 -- if Raised and then not Abort then
1857 -- Raise_From_Controlled_Operation (E);
1860 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1861 Append_To
(Finalizer_Stmts
,
1862 Build_Raise_Statement
(Finalizer_Data
));
1866 -- procedure Fin_Id is
1867 -- Abort : constant Boolean := Triggered_By_Abort;
1869 -- Abort : constant Boolean := False; -- no abort
1871 -- E : Exception_Occurrence; -- All added if flag
1872 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1878 -- Abort_Defer; -- Added if abort is allowed
1879 -- <call to Prev_At_End> -- Added if exists
1880 -- <cleanup statements> -- Added if Acts_As_Clean
1881 -- <jump block> -- Added if Has_Ctrl_Objs
1882 -- <finalization statements> -- Added if Has_Ctrl_Objs
1883 -- <stack release> -- Added if Mark_Id exists
1884 -- Abort_Undefer; -- Added if abort is allowed
1885 -- <exception propagation> -- Added if Has_Ctrl_Objs
1888 -- Create the body of the finalizer
1890 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1892 if Debug_Generated_Code
then
1893 Set_Debug_Info_Needed
(Body_Id
);
1897 Set_Has_Qualified_Name
(Body_Id
);
1898 Set_Has_Fully_Qualified_Name
(Body_Id
);
1902 Make_Subprogram_Body
(Loc
,
1904 Make_Procedure_Specification
(Loc
,
1905 Defining_Unit_Name
=> Body_Id
),
1906 Declarations
=> Finalizer_Decls
,
1907 Handled_Statement_Sequence
=>
1908 Make_Handled_Sequence_Of_Statements
(Loc
,
1909 Statements
=> Finalizer_Stmts
));
1911 -- Step 4: Spec and body insertion, analysis
1915 -- If the package spec has private declarations, the finalizer
1916 -- body must be added to the end of the list in order to have
1917 -- visibility of all private controlled objects.
1919 if For_Package_Spec
then
1920 if Present
(Priv_Decls
) then
1921 Append_To
(Priv_Decls
, Fin_Spec
);
1922 Append_To
(Priv_Decls
, Fin_Body
);
1924 Append_To
(Decls
, Fin_Spec
);
1925 Append_To
(Decls
, Fin_Body
);
1928 -- For package bodies, both the finalizer spec and body are
1929 -- inserted at the end of the package declarations.
1932 Append_To
(Decls
, Fin_Spec
);
1933 Append_To
(Decls
, Fin_Body
);
1936 -- Push the name of the package
1938 Push_Scope
(Spec_Id
);
1946 -- Create the spec for the finalizer. The At_End handler must be
1947 -- able to call the body which resides in a nested structure.
1951 -- procedure Fin_Id; -- Spec
1953 -- <objects and possibly statements>
1954 -- procedure Fin_Id is ... -- Body
1957 -- Fin_Id; -- At_End handler
1960 pragma Assert
(Present
(Spec_Decls
));
1962 -- It maybe possible that we are finalizing 'Old objects which
1963 -- exist in the spec declarations. When this is the case the
1964 -- Finalizer_Insert_Node will come before the end of the
1965 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1966 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1967 -- end of Spec_Decls to prevent its body appearing before its
1968 -- corresponding spec.
1970 if Present
(Finalizer_Insert_Nod
)
1971 and then List_Containing
(Finalizer_Insert_Nod
) = Spec_Decls
1973 Insert_After_And_Analyze
(Finalizer_Insert_Nod
, Fin_Spec
);
1974 Finalizer_Insert_Nod
:= Fin_Spec
;
1976 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
1979 Append_To
(Spec_Decls
, Fin_Spec
);
1983 -- When the finalizer acts solely as a cleanup routine, the body
1984 -- is inserted right after the spec.
1986 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1987 Insert_After
(Fin_Spec
, Fin_Body
);
1989 -- In all other cases the body is inserted after either:
1991 -- 1) The counter update statement of the last controlled object
1992 -- 2) The last top level nested controlled package
1993 -- 3) The last top level controlled instantiation
1996 -- Manually freeze the spec. This is somewhat of a hack because
1997 -- a subprogram is frozen when its body is seen and the freeze
1998 -- node appears right before the body. However, in this case,
1999 -- the spec must be frozen earlier since the At_End handler
2000 -- must be able to call it.
2003 -- procedure Fin_Id; -- Spec
2004 -- [Fin_Id] -- Freeze node
2008 -- Fin_Id; -- At_End handler
2011 Ensure_Freeze_Node
(Fin_Id
);
2012 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
2013 Set_Is_Frozen
(Fin_Id
);
2015 -- In the case where the last construct to contain a controlled
2016 -- object is either a nested package, an instantiation or a
2017 -- freeze node, the body must be inserted directly after the
2018 -- construct, except if the insertion point is already placed
2019 -- after the construct, typically in the statement list.
2021 if Nkind
(Last_Top_Level_Ctrl_Construct
) in
2022 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2024 (List_Containing
(Last_Top_Level_Ctrl_Construct
) = Spec_Decls
2025 and then Present
(Stmts
)
2026 and then List_Containing
(Finalizer_Insert_Nod
) = Stmts
)
2028 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2031 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2034 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2037 -- Never consider that the finalizer procedure is enabled Ghost, even
2038 -- when the corresponding unit is Ghost, as this would lead to an
2039 -- an external name with a ___ghost_ prefix that the binder cannot
2040 -- generate, as it has no knowledge of the Ghost status of units.
2042 Set_Is_Checked_Ghost_Entity
(Fin_Id
, False);
2043 end Create_Finalizer
;
2045 ------------------------
2046 -- New_Finalizer_Name --
2047 ------------------------
2049 function New_Finalizer_Name
2050 (Spec_Id
: Node_Id
; For_Spec
: Boolean) return Name_Id
2052 procedure New_Finalizer_Name
(Id
: Entity_Id
);
2053 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2054 -- has a non-standard scope, process the scope first.
2056 ------------------------
2057 -- New_Finalizer_Name --
2058 ------------------------
2060 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
2062 if Scope
(Id
) = Standard_Standard
then
2063 Get_Name_String
(Chars
(Id
));
2066 New_Finalizer_Name
(Scope
(Id
));
2067 Add_Str_To_Name_Buffer
("__");
2068 Get_Name_String_And_Append
(Chars
(Id
));
2070 end New_Finalizer_Name
;
2072 -- Start of processing for New_Finalizer_Name
2075 -- Create the fully qualified name of the enclosing scope
2077 New_Finalizer_Name
(Spec_Id
);
2080 -- __finalize_[spec|body]
2082 Add_Str_To_Name_Buffer
("__finalize_");
2085 Add_Str_To_Name_Buffer
("spec");
2087 Add_Str_To_Name_Buffer
("body");
2091 end New_Finalizer_Name
;
2093 --------------------------
2094 -- Process_Declarations --
2095 --------------------------
2097 procedure Process_Declarations
2099 Preprocess
: Boolean := False;
2100 Top_Level
: Boolean := False)
2105 Obj_Typ
: Entity_Id
;
2106 Pack_Id
: Entity_Id
;
2110 Old_Counter_Val
: Nat
;
2111 -- This variable is used to determine whether a nested package or
2112 -- instance contains at least one controlled object.
2114 procedure Process_Package_Body
(Decl
: Node_Id
);
2115 -- Process an N_Package_Body node
2117 procedure Processing_Actions
2118 (Has_No_Init
: Boolean := False;
2119 Is_Protected
: Boolean := False);
2120 -- Depending on the mode of operation of Process_Declarations, either
2121 -- increment the controlled object counter, set the controlled object
2122 -- flag and store the last top level construct or process the current
2123 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2124 -- the current declaration may not have initialization proc(s). Flag
2125 -- Is_Protected should be set when the current declaration denotes a
2126 -- simple protected object.
2128 --------------------------
2129 -- Process_Package_Body --
2130 --------------------------
2132 procedure Process_Package_Body
(Decl
: Node_Id
) is
2134 -- Do not inspect an ignored Ghost package body because all
2135 -- code found within will not appear in the final tree.
2137 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2140 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
then
2141 Old_Counter_Val
:= Counter_Val
;
2142 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2144 -- The nested package body is the last construct to contain
2145 -- a controlled object.
2149 and then No
(Last_Top_Level_Ctrl_Construct
)
2150 and then Counter_Val
> Old_Counter_Val
2152 Last_Top_Level_Ctrl_Construct
:= Decl
;
2155 end Process_Package_Body
;
2157 ------------------------
2158 -- Processing_Actions --
2159 ------------------------
2161 procedure Processing_Actions
2162 (Has_No_Init
: Boolean := False;
2163 Is_Protected
: Boolean := False)
2166 -- Library-level tagged type
2168 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2170 Has_Tagged_Types
:= True;
2172 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2173 Last_Top_Level_Ctrl_Construct
:= Decl
;
2176 -- Unregister tagged type, unless No_Tagged_Type_Registration
2179 elsif not Restriction_Active
(No_Tagged_Type_Registration
) then
2180 Process_Tagged_Type_Declaration
(Decl
);
2183 -- Controlled object declaration
2187 Counter_Val
:= Counter_Val
+ 1;
2188 Has_Ctrl_Objs
:= True;
2190 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2191 Last_Top_Level_Ctrl_Construct
:= Decl
;
2195 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2198 end Processing_Actions
;
2200 -- Start of processing for Process_Declarations
2203 if Is_Empty_List
(Decls
) then
2207 -- Process all declarations in reverse order
2209 Decl
:= Last_Non_Pragma
(Decls
);
2210 while Present
(Decl
) loop
2211 -- Library-level tagged types
2213 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2214 Typ
:= Defining_Identifier
(Decl
);
2216 -- Ignored Ghost types do not need any cleanup actions because
2217 -- they will not appear in the final tree.
2219 if Is_Ignored_Ghost_Entity
(Typ
) then
2222 elsif Is_Tagged_Type
(Typ
)
2223 and then Is_Library_Level_Entity
(Typ
)
2224 and then Convention
(Typ
) = Convention_Ada
2225 and then Present
(Access_Disp_Table
(Typ
))
2226 and then not Is_Abstract_Type
(Typ
)
2227 and then not No_Run_Time_Mode
2228 and then not Restriction_Active
(No_Tagged_Type_Registration
)
2229 and then RTE_Available
(RE_Register_Tag
)
2234 -- Regular object declarations
2236 elsif Nkind
(Decl
) = N_Object_Declaration
then
2237 Obj_Id
:= Defining_Identifier
(Decl
);
2238 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2239 Expr
:= Expression
(Decl
);
2241 -- Bypass any form of processing for objects which have their
2242 -- finalization disabled. This applies only to objects at the
2245 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2248 -- Finalization of transient objects are treated separately in
2249 -- order to handle sensitive cases. These include:
2251 -- * Aggregate expansion
2252 -- * If, case, and expression with actions expansion
2253 -- * Transient scopes
2255 -- If one of those contexts has marked the transient object as
2256 -- ignored, do not generate finalization actions for it.
2258 elsif Is_Finalized_Transient
(Obj_Id
)
2259 or else Is_Ignored_Transient
(Obj_Id
)
2263 -- Ignored Ghost objects do not need any cleanup actions
2264 -- because they will not appear in the final tree.
2266 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2269 -- The object is of the form:
2270 -- Obj : [constant] Typ [:= Expr];
2272 -- Do not process the incomplete view of a deferred constant.
2273 -- Note that an object initialized by means of a BIP function
2274 -- call may appear as a deferred constant after expansion
2275 -- activities. These kinds of objects must be finalized.
2277 elsif not Is_Imported
(Obj_Id
)
2278 and then Needs_Finalization
(Obj_Typ
)
2279 and then not (Ekind
(Obj_Id
) = E_Constant
2280 and then not Has_Completion
(Obj_Id
)
2281 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2285 -- The object is of the form:
2286 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2288 -- Obj : Access_Typ :=
2289 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2291 elsif Is_Access_Type
(Obj_Typ
)
2292 and then Needs_Finalization
2293 (Available_View
(Designated_Type
(Obj_Typ
)))
2294 and then Present
(Expr
)
2296 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2298 (Is_Non_BIP_Func_Call
(Expr
)
2299 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2301 Processing_Actions
(Has_No_Init
=> True);
2303 -- Processing for "hook" objects generated for transient
2304 -- objects declared inside an Expression_With_Actions.
2306 elsif Is_Access_Type
(Obj_Typ
)
2307 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2308 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2309 N_Object_Declaration
2311 Processing_Actions
(Has_No_Init
=> True);
2313 -- Process intermediate results of an if expression with one
2314 -- of the alternatives using a controlled function call.
2316 elsif Is_Access_Type
(Obj_Typ
)
2317 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2318 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2319 N_Defining_Identifier
2320 and then Present
(Expr
)
2321 and then Nkind
(Expr
) = N_Null
2323 Processing_Actions
(Has_No_Init
=> True);
2325 -- Simple protected objects which use type System.Tasking.
2326 -- Protected_Objects.Protection to manage their locks should
2327 -- be treated as controlled since they require manual cleanup.
2328 -- The only exception is illustrated in the following example:
2331 -- type Ctrl is new Controlled ...
2332 -- procedure Finalize (Obj : in out Ctrl);
2336 -- package body Pkg is
2337 -- protected Prot is
2338 -- procedure Do_Something (Obj : in out Ctrl);
2341 -- protected body Prot is
2342 -- procedure Do_Something (Obj : in out Ctrl) is ...
2345 -- procedure Finalize (Obj : in out Ctrl) is
2347 -- Prot.Do_Something (Obj);
2351 -- Since for the most part entities in package bodies depend on
2352 -- those in package specs, Prot's lock should be cleaned up
2353 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2354 -- This act however attempts to invoke Do_Something and fails
2355 -- because the lock has disappeared.
2357 elsif Ekind
(Obj_Id
) = E_Variable
2358 and then not In_Library_Level_Package_Body
(Obj_Id
)
2359 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2360 or else Has_Simple_Protected_Object
(Obj_Typ
))
2362 Processing_Actions
(Is_Protected
=> True);
2365 -- Specific cases of object renamings
2367 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2368 Obj_Id
:= Defining_Identifier
(Decl
);
2369 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2371 -- Bypass any form of processing for objects which have their
2372 -- finalization disabled. This applies only to objects at the
2375 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2378 -- Ignored Ghost object renamings do not need any cleanup
2379 -- actions because they will not appear in the final tree.
2381 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2384 -- Return object of a build-in-place function. This case is
2385 -- recognized and marked by the expansion of an extended return
2386 -- statement (see Expand_N_Extended_Return_Statement).
2388 elsif Needs_Finalization
(Obj_Typ
)
2389 and then Is_Return_Object
(Obj_Id
)
2390 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2392 Processing_Actions
(Has_No_Init
=> True);
2395 -- Inspect the freeze node of an access-to-controlled type and
2396 -- look for a delayed finalization master. This case arises when
2397 -- the freeze actions are inserted at a later time than the
2398 -- expansion of the context. Since Build_Finalizer is never called
2399 -- on a single construct twice, the master will be ultimately
2400 -- left out and never finalized. This is also needed for freeze
2401 -- actions of designated types themselves, since in some cases the
2402 -- finalization master is associated with a designated type's
2403 -- freeze node rather than that of the access type (see handling
2404 -- for freeze actions in Build_Finalization_Master).
2406 elsif Nkind
(Decl
) = N_Freeze_Entity
2407 and then Present
(Actions
(Decl
))
2409 Typ
:= Entity
(Decl
);
2411 -- Freeze nodes for ignored Ghost types do not need cleanup
2412 -- actions because they will never appear in the final tree.
2414 if Is_Ignored_Ghost_Entity
(Typ
) then
2417 elsif (Is_Access_Object_Type
(Typ
)
2418 and then Needs_Finalization
2419 (Available_View
(Designated_Type
(Typ
))))
2420 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2422 Old_Counter_Val
:= Counter_Val
;
2424 -- Freeze nodes are considered to be identical to packages
2425 -- and blocks in terms of nesting. The difference is that
2426 -- a finalization master created inside the freeze node is
2427 -- at the same nesting level as the node itself.
2429 Process_Declarations
(Actions
(Decl
), Preprocess
);
2431 -- The freeze node contains a finalization master
2435 and then No
(Last_Top_Level_Ctrl_Construct
)
2436 and then Counter_Val
> Old_Counter_Val
2438 Last_Top_Level_Ctrl_Construct
:= Decl
;
2442 -- Nested package declarations, avoid generics
2444 elsif Nkind
(Decl
) = N_Package_Declaration
then
2445 Pack_Id
:= Defining_Entity
(Decl
);
2446 Spec
:= Specification
(Decl
);
2448 -- Do not inspect an ignored Ghost package because all code
2449 -- found within will not appear in the final tree.
2451 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2454 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2455 Old_Counter_Val
:= Counter_Val
;
2456 Process_Declarations
2457 (Private_Declarations
(Spec
), Preprocess
);
2458 Process_Declarations
2459 (Visible_Declarations
(Spec
), Preprocess
);
2461 -- Either the visible or the private declarations contain a
2462 -- controlled object. The nested package declaration is the
2463 -- last such construct.
2467 and then No
(Last_Top_Level_Ctrl_Construct
)
2468 and then Counter_Val
> Old_Counter_Val
2470 Last_Top_Level_Ctrl_Construct
:= Decl
;
2474 -- Nested package bodies, avoid generics
2476 elsif Nkind
(Decl
) = N_Package_Body
then
2477 Process_Package_Body
(Decl
);
2479 elsif Nkind
(Decl
) = N_Package_Body_Stub
2480 and then Present
(Library_Unit
(Decl
))
2482 Process_Package_Body
(Proper_Body
(Unit
(Library_Unit
(Decl
))));
2484 -- Handle a rare case caused by a controlled transient object
2485 -- created as part of a record init proc. The variable is wrapped
2486 -- in a block, but the block is not associated with a transient
2489 elsif Nkind
(Decl
) = N_Block_Statement
2490 and then Inside_Init_Proc
2492 Old_Counter_Val
:= Counter_Val
;
2494 if Present
(Handled_Statement_Sequence
(Decl
)) then
2495 Process_Declarations
2496 (Statements
(Handled_Statement_Sequence
(Decl
)),
2500 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2502 -- Either the declaration or statement list of the block has a
2503 -- controlled object.
2507 and then No
(Last_Top_Level_Ctrl_Construct
)
2508 and then Counter_Val
> Old_Counter_Val
2510 Last_Top_Level_Ctrl_Construct
:= Decl
;
2513 -- Handle the case where the original context has been wrapped in
2514 -- a block to avoid interference between exception handlers and
2515 -- At_End handlers. Treat the block as transparent and process its
2518 elsif Nkind
(Decl
) = N_Block_Statement
2519 and then Is_Finalization_Wrapper
(Decl
)
2521 if Present
(Handled_Statement_Sequence
(Decl
)) then
2522 Process_Declarations
2523 (Statements
(Handled_Statement_Sequence
(Decl
)),
2527 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2530 Prev_Non_Pragma
(Decl
);
2532 end Process_Declarations
;
2534 --------------------------------
2535 -- Process_Object_Declaration --
2536 --------------------------------
2538 procedure Process_Object_Declaration
2540 Has_No_Init
: Boolean := False;
2541 Is_Protected
: Boolean := False)
2543 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2544 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2546 Init_Typ
: Entity_Id
;
2547 -- The initialization type of the related object declaration. Note
2548 -- that this is not necessarily the same type as Obj_Typ because of
2549 -- possible type derivations.
2551 Obj_Typ
: Entity_Id
;
2552 -- The type of the related object declaration
2554 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2555 -- Func_Id denotes a build-in-place function. Generate the following
2558 -- if BIPallocfrom > Secondary_Stack'Pos
2559 -- and then BIPfinalizationmaster /= null
2562 -- type Ptr_Typ is access Obj_Typ;
2563 -- for Ptr_Typ'Storage_Pool
2564 -- use Base_Pool (BIPfinalizationmaster);
2566 -- Free (Ptr_Typ (Temp));
2570 -- Obj_Typ is the type of the current object, Temp is the original
2571 -- allocation which Obj_Id renames.
2573 procedure Find_Last_Init
2574 (Last_Init
: out Node_Id
;
2575 Body_Insert
: out Node_Id
);
2576 -- Find the last initialization call related to object declaration
2577 -- Decl. Last_Init denotes the last initialization call which follows
2578 -- Decl. Body_Insert denotes a node where the finalizer body could be
2579 -- potentially inserted after (if blocks are involved).
2581 -----------------------------
2582 -- Build_BIP_Cleanup_Stmts --
2583 -----------------------------
2585 function Build_BIP_Cleanup_Stmts
2586 (Func_Id
: Entity_Id
) return Node_Id
2588 Decls
: constant List_Id
:= New_List
;
2589 Fin_Mas_Id
: constant Entity_Id
:=
2590 Build_In_Place_Formal
2591 (Func_Id
, BIP_Finalization_Master
);
2592 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2593 Temp_Id
: constant Entity_Id
:=
2594 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2598 Free_Stmt
: Node_Id
;
2599 Pool_Id
: Entity_Id
;
2600 Ptr_Typ
: Entity_Id
;
2604 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2606 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2609 Make_Object_Renaming_Declaration
(Loc
,
2610 Defining_Identifier
=> Pool_Id
,
2612 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2614 Make_Explicit_Dereference
(Loc
,
2616 Make_Function_Call
(Loc
,
2618 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2619 Parameter_Associations
=> New_List
(
2620 Make_Explicit_Dereference
(Loc
,
2622 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2624 -- Create an access type which uses the storage pool of the
2625 -- caller's finalization master.
2628 -- type Ptr_Typ is access Func_Typ;
2630 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2633 Make_Full_Type_Declaration
(Loc
,
2634 Defining_Identifier
=> Ptr_Typ
,
2636 Make_Access_To_Object_Definition
(Loc
,
2637 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2639 -- Perform minor decoration in order to set the master and the
2640 -- storage pool attributes.
2642 Mutate_Ekind
(Ptr_Typ
, E_Access_Type
);
2643 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2644 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2646 if Debug_Generated_Code
then
2647 Set_Debug_Info_Needed
(Pool_Id
);
2650 -- Create an explicit free statement. Note that the free uses the
2651 -- caller's pool expressed as a renaming.
2654 Make_Free_Statement
(Loc
,
2656 Unchecked_Convert_To
(Ptr_Typ
,
2657 New_Occurrence_Of
(Temp_Id
, Loc
)));
2659 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2661 -- Create a block to house the dummy type and the instantiation as
2662 -- well as to perform the cleanup the temporary.
2668 -- Free (Ptr_Typ (Temp_Id));
2672 Make_Block_Statement
(Loc
,
2673 Declarations
=> Decls
,
2674 Handled_Statement_Sequence
=>
2675 Make_Handled_Sequence_Of_Statements
(Loc
,
2676 Statements
=> New_List
(Free_Stmt
)));
2679 -- if BIPfinalizationmaster /= null then
2683 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2684 Right_Opnd
=> Make_Null
(Loc
));
2686 -- For unconstrained or tagged results, escalate the condition to
2687 -- include the allocation format. Generate:
2689 -- if BIPallocform > Secondary_Stack'Pos
2690 -- and then BIPfinalizationmaster /= null
2693 if Needs_BIP_Alloc_Form
(Func_Id
) then
2695 Alloc
: constant Entity_Id
:=
2696 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2702 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2704 Make_Integer_Literal
(Loc
,
2706 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2708 Right_Opnd
=> Cond
);
2718 Make_If_Statement
(Loc
,
2720 Then_Statements
=> New_List
(Free_Blk
));
2721 end Build_BIP_Cleanup_Stmts
;
2723 --------------------
2724 -- Find_Last_Init --
2725 --------------------
2727 procedure Find_Last_Init
2728 (Last_Init
: out Node_Id
;
2729 Body_Insert
: out Node_Id
)
2731 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2732 -- Find the last initialization call within the statements of
2735 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2736 -- Determine whether node N denotes one of the initialization
2737 -- procedures of types Init_Typ or Obj_Typ.
2739 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2740 -- Obtain the next statement which follows list member Stmt while
2741 -- ignoring artifacts related to access-before-elaboration checks.
2743 -----------------------------
2744 -- Find_Last_Init_In_Block --
2745 -----------------------------
2747 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2748 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2752 -- Examine the individual statements of the block in reverse to
2753 -- locate the last initialization call.
2755 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2756 Stmt
:= Last
(Statements
(HSS
));
2757 while Present
(Stmt
) loop
2759 -- Peek inside nested blocks in case aborts are allowed
2761 if Nkind
(Stmt
) = N_Block_Statement
then
2762 return Find_Last_Init_In_Block
(Stmt
);
2764 elsif Is_Init_Call
(Stmt
) then
2773 end Find_Last_Init_In_Block
;
2779 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2780 function Is_Init_Proc_Of
2781 (Subp_Id
: Entity_Id
;
2782 Typ
: Entity_Id
) return Boolean;
2783 -- Determine whether subprogram Subp_Id is a valid init proc of
2786 ---------------------
2787 -- Is_Init_Proc_Of --
2788 ---------------------
2790 function Is_Init_Proc_Of
2791 (Subp_Id
: Entity_Id
;
2792 Typ
: Entity_Id
) return Boolean
2794 Deep_Init
: Entity_Id
:= Empty
;
2795 Prim_Init
: Entity_Id
:= Empty
;
2796 Type_Init
: Entity_Id
:= Empty
;
2799 -- Obtain all possible initialization routines of the
2800 -- related type and try to match the subprogram entity
2801 -- against one of them.
2805 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2807 -- Primitive Initialize
2809 if Is_Controlled
(Typ
) then
2810 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2812 if Present
(Prim_Init
) then
2813 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2817 -- Type initialization routine
2819 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2820 Type_Init
:= Base_Init_Proc
(Typ
);
2824 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2826 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2828 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2829 end Is_Init_Proc_Of
;
2833 Call_Id
: Entity_Id
;
2835 -- Start of processing for Is_Init_Call
2838 if Nkind
(N
) = N_Procedure_Call_Statement
2839 and then Nkind
(Name
(N
)) = N_Identifier
2841 Call_Id
:= Entity
(Name
(N
));
2843 -- Consider both the type of the object declaration and its
2844 -- related initialization type.
2847 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2849 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2855 -----------------------------
2856 -- Next_Suitable_Statement --
2857 -----------------------------
2859 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2863 -- Skip call markers and Program_Error raises installed by the
2866 Result
:= Next
(Stmt
);
2867 while Present
(Result
) loop
2868 exit when Nkind
(Result
) not in
2869 N_Call_Marker | N_Raise_Program_Error
;
2875 end Next_Suitable_Statement
;
2883 Deep_Init_Found
: Boolean := False;
2884 -- A flag set when a call to [Deep_]Initialize has been found
2886 -- Start of processing for Find_Last_Init
2890 Body_Insert
:= Empty
;
2892 -- Object renamings and objects associated with controlled
2893 -- function results do not require initialization.
2899 Stmt
:= Next_Suitable_Statement
(Decl
);
2901 -- For an object with suppressed initialization, we check whether
2902 -- there is in fact no initialization expression. If there is not,
2903 -- then this is an object declaration that has been turned into a
2904 -- different object declaration that calls the build-in-place
2905 -- function in a 'Reference attribute, as in "F(...)'Reference".
2906 -- We search for that later object declaration, so that the
2907 -- Inc_Decl will be inserted after the call. Otherwise, if the
2908 -- call raises an exception, we will finalize the (uninitialized)
2909 -- object, which is wrong.
2911 if No_Initialization
(Decl
) then
2912 if No
(Expression
(Last_Init
)) then
2915 exit when No
(Last_Init
);
2916 exit when Nkind
(Last_Init
) = N_Object_Declaration
2917 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2918 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2920 and then Is_Expanded_Build_In_Place_Call
2921 (Prefix
(Expression
(Last_Init
)));
2927 -- If the initialization is in the declaration, we're done, so
2928 -- early return if we have no more statements or they have been
2929 -- rewritten, which means that they were in the source code.
2931 elsif No
(Stmt
) or else Original_Node
(Stmt
) /= Stmt
then
2934 -- In all other cases the initialization calls follow the related
2935 -- object. The general structure of object initialization built by
2936 -- routine Default_Initialize_Object is as follows:
2938 -- [begin -- aborts allowed
2940 -- Type_Init_Proc (Obj);
2941 -- [begin] -- exceptions allowed
2942 -- Deep_Initialize (Obj);
2943 -- [exception -- exceptions allowed
2945 -- Deep_Finalize (Obj, Self => False);
2948 -- [at end -- aborts allowed
2952 -- When aborts are allowed, the initialization calls are housed
2955 elsif Nkind
(Stmt
) = N_Block_Statement
then
2956 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2957 Body_Insert
:= Stmt
;
2959 -- Otherwise the initialization calls follow the related object
2962 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2964 -- Check for an optional call to Deep_Initialize which may
2965 -- appear within a block depending on whether the object has
2966 -- controlled components.
2968 if Present
(Stmt_2
) then
2969 if Nkind
(Stmt_2
) = N_Block_Statement
then
2970 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2972 if Present
(Call
) then
2973 Deep_Init_Found
:= True;
2975 Body_Insert
:= Stmt_2
;
2978 elsif Is_Init_Call
(Stmt_2
) then
2979 Deep_Init_Found
:= True;
2980 Last_Init
:= Stmt_2
;
2981 Body_Insert
:= Last_Init
;
2985 -- If the object lacks a call to Deep_Initialize, then it must
2986 -- have a call to its related type init proc.
2988 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2990 Body_Insert
:= Last_Init
;
2998 Count_Ins
: Node_Id
;
3000 Fin_Stmts
: List_Id
:= No_List
;
3003 Label_Id
: Entity_Id
;
3006 -- Start of processing for Process_Object_Declaration
3009 -- Handle the object type and the reference to the object
3011 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
3012 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
3015 if Is_Access_Type
(Obj_Typ
) then
3016 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
3017 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
3019 elsif Is_Concurrent_Type
(Obj_Typ
)
3020 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
3022 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
3023 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3025 elsif Is_Private_Type
(Obj_Typ
)
3026 and then Present
(Full_View
(Obj_Typ
))
3028 Obj_Typ
:= Full_View
(Obj_Typ
);
3029 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3031 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
3032 Obj_Typ
:= Base_Type
(Obj_Typ
);
3033 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
3040 Set_Etype
(Obj_Ref
, Obj_Typ
);
3042 -- Handle the initialization type of the object declaration
3044 Init_Typ
:= Obj_Typ
;
3046 if Is_Private_Type
(Init_Typ
)
3047 and then Present
(Full_View
(Init_Typ
))
3049 Init_Typ
:= Full_View
(Init_Typ
);
3051 elsif Is_Untagged_Derivation
(Init_Typ
) then
3052 Init_Typ
:= Root_Type
(Init_Typ
);
3059 -- Set a new value for the state counter and insert the statement
3060 -- after the object declaration. Generate:
3062 -- Counter := <value>;
3065 Make_Assignment_Statement
(Loc
,
3066 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
3067 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
3069 -- Insert the counter after all initialization has been done. The
3070 -- place of insertion depends on the context.
3072 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
3074 -- The object is initialized by a build-in-place function call.
3075 -- The counter insertion point is after the function call.
3077 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
3078 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
3081 -- The object is initialized by an aggregate. Insert the counter
3082 -- after the last aggregate assignment.
3084 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
3085 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
3088 -- In all other cases the counter is inserted after the last call
3089 -- to either [Deep_]Initialize or the type-specific init proc.
3092 Find_Last_Init
(Count_Ins
, Body_Ins
);
3095 -- In all other cases the counter is inserted after the last call to
3096 -- either [Deep_]Initialize or the type-specific init proc.
3099 Find_Last_Init
(Count_Ins
, Body_Ins
);
3102 -- If the Initialize function is null or trivial, the call will have
3103 -- been replaced with a null statement, in which case place counter
3104 -- declaration after object declaration itself.
3106 if No
(Count_Ins
) then
3110 Insert_After
(Count_Ins
, Inc_Decl
);
3113 -- If the current declaration is the last in the list, the finalizer
3114 -- body needs to be inserted after the set counter statement for the
3115 -- current object declaration. This is complicated by the fact that
3116 -- the set counter statement may appear in abort deferred block. In
3117 -- that case, the proper insertion place is after the block.
3119 if No
(Finalizer_Insert_Nod
) then
3121 -- Insertion after an abort deferred block
3123 if Present
(Body_Ins
) then
3124 Finalizer_Insert_Nod
:= Body_Ins
;
3126 Finalizer_Insert_Nod
:= Inc_Decl
;
3130 -- Create the associated label with this object, generate:
3132 -- L<counter> : label;
3135 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3137 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3138 Label
:= Make_Label
(Loc
, Label_Id
);
3140 Prepend_To
(Finalizer_Decls
,
3141 Make_Implicit_Label_Declaration
(Loc
,
3142 Defining_Identifier
=> Entity
(Label_Id
),
3143 Label_Construct
=> Label
));
3145 -- Create the associated jump with this object, generate:
3147 -- when <counter> =>
3150 Prepend_To
(Jump_Alts
,
3151 Make_Case_Statement_Alternative
(Loc
,
3152 Discrete_Choices
=> New_List
(
3153 Make_Integer_Literal
(Loc
, Counter_Val
)),
3154 Statements
=> New_List
(
3155 Make_Goto_Statement
(Loc
,
3156 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3158 -- Insert the jump destination, generate:
3162 Append_To
(Finalizer_Stmts
, Label
);
3164 -- Disable warnings on Obj_Id. This works around an issue where GCC
3165 -- is not able to detect that Obj_Id is protected by a counter and
3166 -- emits spurious warnings.
3168 if not Comes_From_Source
(Obj_Id
) then
3169 Set_Warnings_Off
(Obj_Id
);
3172 -- Processing for simple protected objects. Such objects require
3173 -- manual finalization of their lock managers.
3175 if Is_Protected
then
3176 if Is_Simple_Protected_Type
(Obj_Typ
) then
3177 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3179 if Present
(Fin_Call
) then
3180 Fin_Stmts
:= New_List
(Fin_Call
);
3183 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3184 if Is_Record_Type
(Obj_Typ
) then
3185 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3186 elsif Is_Array_Type
(Obj_Typ
) then
3187 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3193 -- System.Tasking.Protected_Objects.Finalize_Protection
3201 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3202 Fin_Stmts
:= New_List
(
3203 Make_Block_Statement
(Loc
,
3204 Handled_Statement_Sequence
=>
3205 Make_Handled_Sequence_Of_Statements
(Loc
,
3206 Statements
=> Fin_Stmts
,
3208 Exception_Handlers
=> New_List
(
3209 Make_Exception_Handler
(Loc
,
3210 Exception_Choices
=> New_List
(
3211 Make_Others_Choice
(Loc
)),
3213 Statements
=> New_List
(
3214 Make_Null_Statement
(Loc
)))))));
3217 -- Processing for regular controlled objects
3222 -- [Deep_]Finalize (Obj);
3225 -- when Id : others =>
3226 -- if not Raised then
3228 -- Save_Occurrence (E, Id);
3237 -- Guard against a missing [Deep_]Finalize when the object type
3238 -- was not properly frozen.
3240 if No
(Fin_Call
) then
3241 Fin_Call
:= Make_Null_Statement
(Loc
);
3244 -- For CodePeer, the exception handlers normally generated here
3245 -- generate complex flowgraphs which result in capacity problems.
3246 -- Omitting these handlers for CodePeer is justified as follows:
3248 -- If a handler is dead, then omitting it is surely ok
3250 -- If a handler is live, then CodePeer should flag the
3251 -- potentially-exception-raising construct that causes it
3252 -- to be live. That is what we are interested in, not what
3253 -- happens after the exception is raised.
3255 if Exceptions_OK
and not CodePeer_Mode
then
3256 Fin_Stmts
:= New_List
(
3257 Make_Block_Statement
(Loc
,
3258 Handled_Statement_Sequence
=>
3259 Make_Handled_Sequence_Of_Statements
(Loc
,
3260 Statements
=> New_List
(Fin_Call
),
3262 Exception_Handlers
=> New_List
(
3263 Build_Exception_Handler
3264 (Finalizer_Data
, For_Package
)))));
3266 -- When exception handlers are prohibited, the finalization call
3267 -- appears unprotected. Any exception raised during finalization
3268 -- will bypass the circuitry which ensures the cleanup of all
3269 -- remaining objects.
3272 Fin_Stmts
:= New_List
(Fin_Call
);
3275 -- If we are dealing with a return object of a build-in-place
3276 -- function, generate the following cleanup statements:
3278 -- if BIPallocfrom > Secondary_Stack'Pos
3279 -- and then BIPfinalizationmaster /= null
3282 -- type Ptr_Typ is access Obj_Typ;
3283 -- for Ptr_Typ'Storage_Pool use
3284 -- Base_Pool (BIPfinalizationmaster.all).all;
3286 -- Free (Ptr_Typ (Temp));
3290 -- The generated code effectively detaches the temporary from the
3291 -- caller finalization master and deallocates the object.
3293 if Is_Return_Object
(Obj_Id
) then
3295 Func_Id
: constant Entity_Id
:=
3296 Return_Applies_To
(Scope
(Obj_Id
));
3299 if Is_Build_In_Place_Function
(Func_Id
)
3300 and then Needs_BIP_Finalization_Master
(Func_Id
)
3302 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3307 if Ekind
(Obj_Id
) in E_Constant | E_Variable
3308 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3310 -- Temporaries created for the purpose of "exporting" a
3311 -- transient object out of an Expression_With_Actions (EWA)
3312 -- need guards. The following illustrates the usage of such
3315 -- Access_Typ : access [all] Obj_Typ;
3316 -- Temp : Access_Typ := null;
3317 -- <Counter> := ...;
3320 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3321 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3323 -- Temp := Ctrl_Trans'Unchecked_Access;
3326 -- The finalization machinery does not process EWA nodes as
3327 -- this may lead to premature finalization of expressions. Note
3328 -- that Temp is marked as being properly initialized regardless
3329 -- of whether the initialization of Ctrl_Trans succeeded. Since
3330 -- a failed initialization may leave Temp with a value of null,
3331 -- add a guard to handle this case:
3333 -- if Obj /= null then
3334 -- <object finalization statements>
3337 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3338 N_Object_Declaration
3340 Fin_Stmts
:= New_List
(
3341 Make_If_Statement
(Loc
,
3344 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3345 Right_Opnd
=> Make_Null
(Loc
)),
3346 Then_Statements
=> Fin_Stmts
));
3348 -- Return objects use a flag to aid in processing their
3349 -- potential finalization when the enclosing function fails
3350 -- to return properly. Generate:
3353 -- <object finalization statements>
3357 Fin_Stmts
:= New_List
(
3358 Make_If_Statement
(Loc
,
3363 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3365 Then_Statements
=> Fin_Stmts
));
3370 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3372 -- Since the declarations are examined in reverse, the state counter
3373 -- must be decremented in order to keep with the true position of
3376 Counter_Val
:= Counter_Val
- 1;
3377 end Process_Object_Declaration
;
3379 -------------------------------------
3380 -- Process_Tagged_Type_Declaration --
3381 -------------------------------------
3383 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3384 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3385 DT_Ptr
: constant Entity_Id
:=
3386 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3389 -- Ada.Tags.Unregister_Tag (<Typ>P);
3391 Append_To
(Tagged_Type_Stmts
,
3392 Make_Procedure_Call_Statement
(Loc
,
3394 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3395 Parameter_Associations
=> New_List
(
3396 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3397 end Process_Tagged_Type_Declaration
;
3399 -- Start of processing for Build_Finalizer
3404 -- Do not perform this expansion in SPARK mode because it is not
3407 if GNATprove_Mode
then
3411 -- Step 1: Extract all lists which may contain controlled objects or
3412 -- library-level tagged types.
3414 if For_Package_Spec
then
3415 Decls
:= Visible_Declarations
(Specification
(N
));
3416 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3418 -- Retrieve the package spec id
3420 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3422 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3423 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3426 -- Accept statement, block, entry body, package body, protected body,
3427 -- subprogram body or task body.
3430 Decls
:= Declarations
(N
);
3431 HSS
:= Handled_Statement_Sequence
(N
);
3433 if Present
(HSS
) then
3434 if Present
(Statements
(HSS
)) then
3435 Stmts
:= Statements
(HSS
);
3438 if Present
(At_End_Proc
(HSS
)) then
3439 Prev_At_End
:= At_End_Proc
(HSS
);
3443 -- Retrieve the package spec id for package bodies
3445 if For_Package_Body
then
3446 Spec_Id
:= Corresponding_Spec
(N
);
3450 -- We do not need to process nested packages since they are handled by
3451 -- the finalizer of the enclosing scope, including at library level.
3452 -- And we do not build two finalizers for an instance without body that
3453 -- is a library unit (see Analyze_Package_Instantiation).
3456 and then (not Is_Compilation_Unit
(Spec_Id
)
3457 or else (Is_Generic_Instance
(Spec_Id
)
3458 and then Package_Instantiation
(Spec_Id
) = N
))
3463 -- Step 2: Object [pre]processing
3467 -- Preprocess the visible declarations now in order to obtain the
3468 -- correct number of controlled object by the time the private
3469 -- declarations are processed.
3471 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3473 -- From all the possible contexts, only package specifications may
3474 -- have private declarations.
3476 if For_Package_Spec
then
3477 Process_Declarations
3478 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3481 -- The current context may lack controlled objects, but require some
3482 -- other form of completion (task termination for instance). In such
3483 -- cases, the finalizer must be created and carry the additional
3486 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3490 -- The preprocessing has determined that the context has controlled
3491 -- objects or library-level tagged types.
3493 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3495 -- Private declarations are processed first in order to preserve
3496 -- possible dependencies between public and private objects.
3498 if For_Package_Spec
then
3499 Process_Declarations
(Priv_Decls
);
3502 Process_Declarations
(Decls
);
3508 -- Preprocess both declarations and statements
3510 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3511 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3513 -- At this point it is known that N has controlled objects. Ensure
3514 -- that N has a declarative list since the finalizer spec will be
3517 if Has_Ctrl_Objs
and then No
(Decls
) then
3518 Set_Declarations
(N
, New_List
);
3519 Decls
:= Declarations
(N
);
3520 Spec_Decls
:= Decls
;
3523 -- The current context may lack controlled objects, but require some
3524 -- other form of completion (task termination for instance). In such
3525 -- cases, the finalizer must be created and carry the additional
3528 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3532 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3533 Process_Declarations
(Stmts
);
3534 Process_Declarations
(Decls
);
3538 -- Step 3: Finalizer creation
3540 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3543 end Build_Finalizer
;
3545 --------------------------
3546 -- Build_Finalizer_Call --
3547 --------------------------
3549 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3551 -- Do not perform this expansion in SPARK mode because we do not create
3552 -- finalizers in the first place.
3554 if GNATprove_Mode
then
3558 -- If the construct to be cleaned up is a protected subprogram body, the
3559 -- finalizer call needs to be associated with the block that wraps the
3560 -- unprotected version of the subprogram. The following illustrates this
3563 -- procedure Prot_SubpP is
3564 -- procedure finalizer is
3566 -- Service_Entries (Prot_Obj);
3573 -- Prot_SubpN (Prot_Obj);
3580 Loc
: constant Source_Ptr
:= Sloc
(N
);
3582 Is_Protected_Subp_Body
: constant Boolean :=
3583 Nkind
(N
) = N_Subprogram_Body
3584 and then Is_Protected_Subprogram_Body
(N
);
3585 -- True if N is the protected version of a subprogram that belongs to
3586 -- a protected type.
3588 HSS
: constant Node_Id
:=
3589 (if Is_Protected_Subp_Body
3590 then Handled_Statement_Sequence
3591 (Last
(Statements
(Handled_Statement_Sequence
(N
))))
3592 else Handled_Statement_Sequence
(N
));
3594 -- We attach the At_End_Proc to the HSS if this is an accept
3595 -- statement or extended return statement. Also in the case of
3596 -- a protected subprogram, because if Service_Entries raises an
3597 -- exception, we do not lock the PO, so we also do not want to
3600 Use_HSS
: constant Boolean :=
3601 Nkind
(N
) in N_Accept_Statement | N_Extended_Return_Statement
3602 or else Is_Protected_Subp_Body
;
3604 At_End_Proc_Bearer
: constant Node_Id
:= (if Use_HSS
then HSS
else N
);
3606 pragma Assert
(No
(At_End_Proc
(At_End_Proc_Bearer
)));
3607 Set_At_End_Proc
(At_End_Proc_Bearer
, New_Occurrence_Of
(Fin_Id
, Loc
));
3608 -- Attach reference to finalizer to tree, for LLVM use
3609 Set_Parent
(At_End_Proc
(At_End_Proc_Bearer
), At_End_Proc_Bearer
);
3610 Analyze
(At_End_Proc
(At_End_Proc_Bearer
));
3611 Expand_At_End_Handler
(At_End_Proc_Bearer
, Empty
);
3613 end Build_Finalizer_Call
;
3615 ---------------------
3616 -- Build_Late_Proc --
3617 ---------------------
3619 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3621 for Final_Prim
in Name_Of
'Range loop
3622 if Name_Of
(Final_Prim
) = Nam
then
3625 (Prim
=> Final_Prim
,
3627 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3630 end Build_Late_Proc
;
3632 -------------------------------
3633 -- Build_Object_Declarations --
3634 -------------------------------
3636 procedure Build_Object_Declarations
3637 (Data
: out Finalization_Exception_Data
;
3640 For_Package
: Boolean := False)
3645 -- This variable captures an unused dummy internal entity, see the
3646 -- comment associated with its use.
3649 pragma Assert
(Decls
/= No_List
);
3651 -- Always set the proper location as it may be needed even when
3652 -- exception propagation is forbidden.
3656 if Restriction_Active
(No_Exception_Propagation
) then
3657 Data
.Abort_Id
:= Empty
;
3659 Data
.Raised_Id
:= Empty
;
3663 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3665 -- In certain scenarios, finalization can be triggered by an abort. If
3666 -- the finalization itself fails and raises an exception, the resulting
3667 -- Program_Error must be supressed and replaced by an abort signal. In
3668 -- order to detect this scenario, save the state of entry into the
3669 -- finalization code.
3671 -- This is not needed for library-level finalizers as they are called by
3672 -- the environment task and cannot be aborted.
3674 if not For_Package
then
3675 if Abort_Allowed
then
3676 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3679 -- Abort_Id : constant Boolean := <A_Expr>;
3682 Make_Object_Declaration
(Loc
,
3683 Defining_Identifier
=> Data
.Abort_Id
,
3684 Constant_Present
=> True,
3685 Object_Definition
=>
3686 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3688 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3690 -- Abort is not required
3693 -- Generate a dummy entity to ensure that the internal symbols are
3694 -- in sync when a unit is compiled with and without aborts.
3696 Dummy
:= Make_Temporary
(Loc
, 'A');
3697 Data
.Abort_Id
:= Empty
;
3700 -- Library-level finalizers
3703 Data
.Abort_Id
:= Empty
;
3706 if Exception_Extra_Info
then
3707 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3710 -- E_Id : Exception_Occurrence;
3713 Make_Object_Declaration
(Loc
,
3714 Defining_Identifier
=> Data
.E_Id
,
3715 Object_Definition
=>
3716 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3717 Set_No_Initialization
(Decl
);
3719 Append_To
(Decls
, Decl
);
3726 -- Raised_Id : Boolean := False;
3729 Make_Object_Declaration
(Loc
,
3730 Defining_Identifier
=> Data
.Raised_Id
,
3731 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3732 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3734 if Debug_Generated_Code
then
3735 Set_Debug_Info_Needed
(Data
.Raised_Id
);
3737 end Build_Object_Declarations
;
3739 ---------------------------
3740 -- Build_Raise_Statement --
3741 ---------------------------
3743 function Build_Raise_Statement
3744 (Data
: Finalization_Exception_Data
) return Node_Id
3750 -- Standard run-time use the specialized routine
3751 -- Raise_From_Controlled_Operation.
3753 if Exception_Extra_Info
3754 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3757 Make_Procedure_Call_Statement
(Data
.Loc
,
3760 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3761 Parameter_Associations
=>
3762 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3764 -- Restricted run-time: exception messages are not supported and hence
3765 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3770 Make_Raise_Program_Error
(Data
.Loc
,
3771 Reason
=> PE_Finalize_Raised_Exception
);
3776 -- Raised_Id and then not Abort_Id
3780 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3782 if Present
(Data
.Abort_Id
) then
3783 Expr
:= Make_And_Then
(Data
.Loc
,
3786 Make_Op_Not
(Data
.Loc
,
3787 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3792 -- if Raised_Id and then not Abort_Id then
3793 -- Raise_From_Controlled_Operation (E_Id);
3795 -- raise Program_Error; -- restricted runtime
3799 Make_If_Statement
(Data
.Loc
,
3801 Then_Statements
=> New_List
(Stmt
));
3802 end Build_Raise_Statement
;
3804 -----------------------------
3805 -- Build_Record_Deep_Procs --
3806 -----------------------------
3808 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3812 (Prim
=> Initialize_Case
,
3814 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3816 if not Is_Limited_View
(Typ
) then
3819 (Prim
=> Adjust_Case
,
3821 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3824 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3825 -- suppressed since these routine will not be used.
3827 if not Restriction_Active
(No_Finalization
) then
3830 (Prim
=> Finalize_Case
,
3832 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3834 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3836 if not CodePeer_Mode
then
3839 (Prim
=> Address_Case
,
3841 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3844 end Build_Record_Deep_Procs
;
3850 function Cleanup_Array
3853 Typ
: Entity_Id
) return List_Id
3855 Loc
: constant Source_Ptr
:= Sloc
(N
);
3856 Index_List
: constant List_Id
:= New_List
;
3858 function Free_Component
return List_Id
;
3859 -- Generate the code to finalize the task or protected subcomponents
3860 -- of a single component of the array.
3862 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3863 -- Generate a loop over one dimension of the array
3865 --------------------
3866 -- Free_Component --
3867 --------------------
3869 function Free_Component
return List_Id
is
3870 Stmts
: List_Id
:= New_List
;
3872 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3875 -- Component type is known to contain tasks or protected objects
3878 Make_Indexed_Component
(Loc
,
3879 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3880 Expressions
=> Index_List
);
3882 Set_Etype
(Tsk
, C_Typ
);
3884 if Is_Task_Type
(C_Typ
) then
3885 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3887 elsif Is_Simple_Protected_Type
(C_Typ
) then
3888 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3890 elsif Is_Record_Type
(C_Typ
) then
3891 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3893 elsif Is_Array_Type
(C_Typ
) then
3894 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3900 ------------------------
3901 -- Free_One_Dimension --
3902 ------------------------
3904 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3908 if Dim
> Number_Dimensions
(Typ
) then
3909 return Free_Component
;
3911 -- Here we generate the required loop
3914 Index
:= Make_Temporary
(Loc
, 'J');
3915 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3918 Make_Implicit_Loop_Statement
(N
,
3919 Identifier
=> Empty
,
3921 Make_Iteration_Scheme
(Loc
,
3922 Loop_Parameter_Specification
=>
3923 Make_Loop_Parameter_Specification
(Loc
,
3924 Defining_Identifier
=> Index
,
3925 Discrete_Subtype_Definition
=>
3926 Make_Attribute_Reference
(Loc
,
3927 Prefix
=> Duplicate_Subexpr
(Obj
),
3928 Attribute_Name
=> Name_Range
,
3929 Expressions
=> New_List
(
3930 Make_Integer_Literal
(Loc
, Dim
))))),
3931 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3933 end Free_One_Dimension
;
3935 -- Start of processing for Cleanup_Array
3938 return Free_One_Dimension
(1);
3941 --------------------
3942 -- Cleanup_Record --
3943 --------------------
3945 function Cleanup_Record
3948 Typ
: Entity_Id
) return List_Id
3950 Loc
: constant Source_Ptr
:= Sloc
(N
);
3951 Stmts
: constant List_Id
:= New_List
;
3952 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3958 if Has_Discriminants
(U_Typ
)
3959 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3960 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3963 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3965 -- For now, do not attempt to free a component that may appear in a
3966 -- variant, and instead issue a warning. Doing this "properly" would
3967 -- require building a case statement and would be quite a mess. Note
3968 -- that the RM only requires that free "work" for the case of a task
3969 -- access value, so already we go way beyond this in that we deal
3970 -- with the array case and non-discriminated record cases.
3973 ("task/protected object in variant record will not be freed??", N
);
3974 return New_List
(Make_Null_Statement
(Loc
));
3977 Comp
:= First_Component
(U_Typ
);
3978 while Present
(Comp
) loop
3979 if Chars
(Comp
) /= Name_uParent
3980 and then (Has_Task
(Etype
(Comp
))
3981 or else Has_Simple_Protected_Object
(Etype
(Comp
)))
3984 Make_Selected_Component
(Loc
,
3985 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3986 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3987 Set_Etype
(Tsk
, Etype
(Comp
));
3989 if Is_Task_Type
(Etype
(Comp
)) then
3990 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3992 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3993 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3995 elsif Is_Record_Type
(Etype
(Comp
)) then
3997 -- Recurse, by generating the prefix of the argument to the
3998 -- eventual cleanup call.
4000 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
4002 elsif Is_Array_Type
(Etype
(Comp
)) then
4003 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
4007 Next_Component
(Comp
);
4013 ------------------------------
4014 -- Cleanup_Protected_Object --
4015 ------------------------------
4017 function Cleanup_Protected_Object
4019 Ref
: Node_Id
) return Node_Id
4021 Loc
: constant Source_Ptr
:= Sloc
(N
);
4024 -- For restricted run-time libraries (Ravenscar), tasks are
4025 -- non-terminating, and protected objects can only appear at library
4026 -- level, so we do not want finalization of protected objects.
4028 if Restricted_Profile
then
4033 Make_Procedure_Call_Statement
(Loc
,
4035 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
4036 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4038 end Cleanup_Protected_Object
;
4044 function Cleanup_Task
4046 Ref
: Node_Id
) return Node_Id
4048 Loc
: constant Source_Ptr
:= Sloc
(N
);
4051 -- For restricted run-time libraries (Ravenscar), tasks are
4052 -- non-terminating and they can only appear at library level,
4053 -- so we do not want finalization of task objects.
4055 if Restricted_Profile
then
4060 Make_Procedure_Call_Statement
(Loc
,
4062 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
4063 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
4067 --------------------------------------
4068 -- Check_Unnesting_Elaboration_Code --
4069 --------------------------------------
4071 procedure Check_Unnesting_Elaboration_Code
(N
: Node_Id
) is
4072 Loc
: constant Source_Ptr
:= Sloc
(N
);
4073 Block_Elab_Proc
: Entity_Id
:= Empty
;
4075 procedure Set_Block_Elab_Proc
;
4076 -- Create a defining identifier for a procedure that will replace
4077 -- a block with nested subprograms (unless it has already been created,
4078 -- in which case this is a no-op).
4080 procedure Set_Block_Elab_Proc
is
4082 if No
(Block_Elab_Proc
) then
4083 Block_Elab_Proc
:= Make_Temporary
(Loc
, 'I');
4085 end Set_Block_Elab_Proc
;
4087 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
);
4088 -- Find entities in the elaboration code of a library package body that
4089 -- contain or represent a subprogram body. A body can appear within a
4090 -- block or a loop or can appear by itself if generated for an object
4091 -- declaration that involves controlled actions. The first such entity
4092 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4093 -- that will be used to reset the scopes of all entities that become
4094 -- local to the new elaboration procedure. This is needed for subsequent
4095 -- unnesting actions, which depend on proper setting of the Scope links
4096 -- to determine the nesting level of each subprogram.
4098 -----------------------
4099 -- Find_Local_Scope --
4100 -----------------------
4102 procedure Reset_Scopes_To_Block_Elab_Proc
(L
: List_Id
) is
4109 while Present
(Stat
) loop
4110 case Nkind
(Stat
) is
4111 when N_Block_Statement
=>
4112 if Present
(Identifier
(Stat
)) then
4113 Id
:= Entity
(Identifier
(Stat
));
4115 -- The Scope of this block needs to be reset to the new
4116 -- procedure if the block contains nested subprograms.
4118 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4119 Set_Block_Elab_Proc
;
4120 Set_Scope
(Id
, Block_Elab_Proc
);
4124 when N_Loop_Statement
=>
4125 Id
:= Entity
(Identifier
(Stat
));
4127 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4128 if Scope
(Id
) = Current_Scope
then
4129 Set_Block_Elab_Proc
;
4130 Set_Scope
(Id
, Block_Elab_Proc
);
4134 -- We traverse the loop's statements as well, which may
4135 -- include other block (etc.) statements that need to have
4136 -- their Scope set to Block_Elab_Proc. (Is this really the
4137 -- case, or do such nested blocks refer to the loop scope
4138 -- rather than the loop's enclosing scope???.)
4140 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Stat
));
4142 when N_If_Statement
=>
4143 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Stat
));
4144 Reset_Scopes_To_Block_Elab_Proc
(Else_Statements
(Stat
));
4146 Node
:= First
(Elsif_Parts
(Stat
));
4147 while Present
(Node
) loop
4148 Reset_Scopes_To_Block_Elab_Proc
(Then_Statements
(Node
));
4152 when N_Case_Statement
=>
4153 Node
:= First
(Alternatives
(Stat
));
4154 while Present
(Node
) loop
4155 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Node
));
4159 -- Reset the Scope of a subprogram occurring at the top level
4161 when N_Subprogram_Body
=>
4162 Id
:= Defining_Entity
(Stat
);
4164 Set_Block_Elab_Proc
;
4165 Set_Scope
(Id
, Block_Elab_Proc
);
4173 end Reset_Scopes_To_Block_Elab_Proc
;
4177 H_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4178 Elab_Body
: Node_Id
;
4179 Elab_Call
: Node_Id
;
4181 -- Start of processing for Check_Unnesting_Elaboration_Code
4184 if Present
(H_Seq
) then
4185 Reset_Scopes_To_Block_Elab_Proc
(Statements
(H_Seq
));
4187 -- There may be subprograms declared in the exception handlers
4188 -- of the current body.
4190 if Present
(Exception_Handlers
(H_Seq
)) then
4192 Handler
: Node_Id
:= First
(Exception_Handlers
(H_Seq
));
4194 while Present
(Handler
) loop
4195 Reset_Scopes_To_Block_Elab_Proc
(Statements
(Handler
));
4202 if Present
(Block_Elab_Proc
) then
4204 Make_Subprogram_Body
(Loc
,
4206 Make_Procedure_Specification
(Loc
,
4207 Defining_Unit_Name
=> Block_Elab_Proc
),
4208 Declarations
=> New_List
,
4209 Handled_Statement_Sequence
=>
4210 Relocate_Node
(Handled_Statement_Sequence
(N
)));
4213 Make_Procedure_Call_Statement
(Loc
,
4214 Name
=> New_Occurrence_Of
(Block_Elab_Proc
, Loc
));
4216 Append_To
(Declarations
(N
), Elab_Body
);
4217 Analyze
(Elab_Body
);
4218 Set_Has_Nested_Subprogram
(Block_Elab_Proc
);
4220 Set_Handled_Statement_Sequence
(N
,
4221 Make_Handled_Sequence_Of_Statements
(Loc
,
4222 Statements
=> New_List
(Elab_Call
)));
4224 Analyze
(Elab_Call
);
4226 -- Could we reset the scopes of entities associated with the new
4227 -- procedure here via a loop over entities rather than doing it in
4228 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4231 end Check_Unnesting_Elaboration_Code
;
4233 ---------------------------------------
4234 -- Check_Unnesting_In_Decls_Or_Stmts --
4235 ---------------------------------------
4237 procedure Check_Unnesting_In_Decls_Or_Stmts
(Decls_Or_Stmts
: List_Id
) is
4238 Decl_Or_Stmt
: Node_Id
;
4241 if Unnest_Subprogram_Mode
4242 and then Present
(Decls_Or_Stmts
)
4244 Decl_Or_Stmt
:= First
(Decls_Or_Stmts
);
4245 while Present
(Decl_Or_Stmt
) loop
4246 if Nkind
(Decl_Or_Stmt
) = N_Block_Statement
4247 and then Contains_Subprogram
(Entity
(Identifier
(Decl_Or_Stmt
)))
4249 Unnest_Block
(Decl_Or_Stmt
);
4251 -- If-statements may contain subprogram bodies at the outer level
4252 -- of their statement lists, and the subprograms may make up-level
4253 -- references (such as to objects declared in the same statement
4254 -- list). Unlike block and loop cases, however, we don't have an
4255 -- entity on which to test the Contains_Subprogram flag, so
4256 -- Unnest_If_Statement must traverse the statement lists to
4257 -- determine whether there are nested subprograms present.
4259 elsif Nkind
(Decl_Or_Stmt
) = N_If_Statement
then
4260 Unnest_If_Statement
(Decl_Or_Stmt
);
4262 elsif Nkind
(Decl_Or_Stmt
) = N_Loop_Statement
then
4264 Id
: constant Entity_Id
:=
4265 Entity
(Identifier
(Decl_Or_Stmt
));
4268 -- When a top-level loop within declarations of a library
4269 -- package spec or body contains nested subprograms, we wrap
4270 -- it in a procedure to handle possible up-level references
4271 -- to entities associated with the loop (such as loop
4274 if Present
(Id
) and then Contains_Subprogram
(Id
) then
4275 Unnest_Loop
(Decl_Or_Stmt
);
4279 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Declaration
4280 and then not Modify_Tree_For_C
4282 Check_Unnesting_In_Decls_Or_Stmts
4283 (Visible_Declarations
(Specification
(Decl_Or_Stmt
)));
4284 Check_Unnesting_In_Decls_Or_Stmts
4285 (Private_Declarations
(Specification
(Decl_Or_Stmt
)));
4287 elsif Nkind
(Decl_Or_Stmt
) = N_Package_Body
4288 and then not Modify_Tree_For_C
4290 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(Decl_Or_Stmt
));
4291 if Present
(Statements
4292 (Handled_Statement_Sequence
(Decl_Or_Stmt
)))
4294 Check_Unnesting_In_Decls_Or_Stmts
(Statements
4295 (Handled_Statement_Sequence
(Decl_Or_Stmt
)));
4296 Check_Unnesting_In_Handlers
(Decl_Or_Stmt
);
4300 Next
(Decl_Or_Stmt
);
4303 end Check_Unnesting_In_Decls_Or_Stmts
;
4305 ---------------------------------
4306 -- Check_Unnesting_In_Handlers --
4307 ---------------------------------
4309 procedure Check_Unnesting_In_Handlers
(N
: Node_Id
) is
4310 Stmt_Seq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
4313 if Present
(Stmt_Seq
)
4314 and then Present
(Exception_Handlers
(Stmt_Seq
))
4317 Handler
: Node_Id
:= First
(Exception_Handlers
(Stmt_Seq
));
4319 while Present
(Handler
) loop
4320 if Present
(Statements
(Handler
)) then
4321 Check_Unnesting_In_Decls_Or_Stmts
(Statements
(Handler
));
4328 end Check_Unnesting_In_Handlers
;
4330 ------------------------------
4331 -- Check_Visibly_Controlled --
4332 ------------------------------
4334 procedure Check_Visibly_Controlled
4335 (Prim
: Final_Primitives
;
4337 E
: in out Entity_Id
;
4338 Cref
: in out Node_Id
)
4340 Parent_Type
: Entity_Id
;
4344 if Is_Derived_Type
(Typ
)
4345 and then Comes_From_Source
(E
)
4346 and then No
(Overridden_Operation
(E
))
4348 -- We know that the explicit operation on the type does not override
4349 -- the inherited operation of the parent, and that the derivation
4350 -- is from a private type that is not visibly controlled.
4352 Parent_Type
:= Etype
(Typ
);
4353 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
4355 if Present
(Op
) then
4358 -- Wrap the object to be initialized into the proper
4359 -- unchecked conversion, to be compatible with the operation
4362 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4363 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4365 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4369 end Check_Visibly_Controlled
;
4371 --------------------------
4372 -- Contains_Subprogram --
4373 --------------------------
4375 function Contains_Subprogram
(Blk
: Entity_Id
) return Boolean is
4379 E
:= First_Entity
(Blk
);
4381 while Present
(E
) loop
4382 if Is_Subprogram
(E
) then
4385 elsif Ekind
(E
) in E_Block | E_Loop
4386 and then Contains_Subprogram
(E
)
4395 end Contains_Subprogram
;
4401 function Convert_View
(Proc
: Entity_Id
; Arg
: Node_Id
) return Node_Id
is
4402 Ftyp
: constant Entity_Id
:= Etype
(First_Formal
(Proc
));
4407 if Nkind
(Arg
) in N_Type_Conversion | N_Unchecked_Type_Conversion
then
4408 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4410 Atyp
:= Etype
(Arg
);
4413 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4414 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4416 elsif Present
(Atyp
)
4417 and then Atyp
/= Ftyp
4418 and then (Is_Private_Type
(Ftyp
)
4419 or else Is_Private_Type
(Atyp
)
4420 or else Is_Private_Type
(Base_Type
(Atyp
)))
4421 and then Implementation_Base_Type
(Atyp
) =
4422 Implementation_Base_Type
(Ftyp
)
4424 return Unchecked_Convert_To
(Ftyp
, Arg
);
4426 -- If the argument is already a conversion, as generated by
4427 -- Make_Init_Call, set the target type to the type of the formal
4428 -- directly, to avoid spurious typing problems.
4430 elsif Nkind
(Arg
) in N_Unchecked_Type_Conversion | N_Type_Conversion
4431 and then not Is_Class_Wide_Type
(Atyp
)
4433 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4434 Set_Etype
(Arg
, Ftyp
);
4437 -- Otherwise, introduce a conversion when the designated object
4438 -- has a type derived from the formal of the controlled routine.
4440 elsif Is_Private_Type
(Ftyp
)
4441 and then Present
(Atyp
)
4442 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4444 return Unchecked_Convert_To
(Ftyp
, Arg
);
4451 -------------------------------
4452 -- Establish_Transient_Scope --
4453 -------------------------------
4455 -- This procedure is called each time a transient block has to be inserted
4456 -- that is to say for each call to a function with unconstrained or tagged
4457 -- result. It creates a new scope on the scope stack in order to enclose
4458 -- all transient variables generated.
4460 procedure Establish_Transient_Scope
4462 Manage_Sec_Stack
: Boolean)
4464 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4465 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4467 function Find_Enclosing_Transient_Scope
return Int
;
4468 -- Examine the scope stack looking for the nearest enclosing transient
4469 -- scope within the innermost enclosing package or subprogram. Return
4470 -- its index in the table or else -1 if no such scope exists.
4472 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
4473 -- Locate a suitable context for arbitrary node N which may need to be
4474 -- serviced by a transient scope. Return Empty if no suitable context
4477 procedure Delegate_Sec_Stack_Management
;
4478 -- Move the management of the secondary stack to the nearest enclosing
4481 procedure Create_Transient_Scope
(Context
: Node_Id
);
4482 -- Place a new scope on the scope stack in order to service construct
4483 -- Context. Context is the node found by Find_Transient_Context. The
4484 -- new scope may also manage the secondary stack.
4486 ----------------------------
4487 -- Create_Transient_Scope --
4488 ----------------------------
4490 procedure Create_Transient_Scope
(Context
: Node_Id
) is
4491 Loc
: constant Source_Ptr
:= Sloc
(N
);
4493 Iter_Loop
: Entity_Id
;
4494 Trans_Scop
: constant Entity_Id
:=
4495 New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4498 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4500 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4503 Push_Scope
(Trans_Scop
);
4504 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= Context
;
4505 Set_Scope_Is_Transient
;
4507 -- The transient scope must also manage the secondary stack
4509 if Manage_Sec_Stack
then
4510 Set_Uses_Sec_Stack
(Trans_Scop
);
4511 Check_Restriction
(No_Secondary_Stack
, N
);
4513 -- The expansion of iterator loops generates references to objects
4514 -- in order to extract elements from a container:
4516 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4517 -- Obj : <object type> renames Ref.all.Element.all;
4519 -- These references are controlled and returned on the secondary
4520 -- stack. A new reference is created at each iteration of the loop
4521 -- and as a result it must be finalized and the space occupied by
4522 -- it on the secondary stack reclaimed at the end of the current
4525 -- When the context that requires a transient scope is a call to
4526 -- routine Reference, the node to be wrapped is the source object:
4528 -- for Obj of Container loop
4530 -- Routine Wrap_Transient_Declaration however does not generate
4531 -- a physical block as wrapping a declaration will kill it too
4532 -- early. To handle this peculiar case, mark the related iterator
4533 -- loop as requiring the secondary stack. This signals the
4534 -- finalization machinery to manage the secondary stack (see
4535 -- routine Process_Statements_For_Controlled_Objects).
4537 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4539 if Present
(Iter_Loop
) then
4540 Set_Uses_Sec_Stack
(Iter_Loop
);
4544 if Debug_Flag_W
then
4545 Write_Str
(" <Transient>");
4548 end Create_Transient_Scope
;
4550 -----------------------------------
4551 -- Delegate_Sec_Stack_Management --
4552 -----------------------------------
4554 procedure Delegate_Sec_Stack_Management
is
4556 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4558 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4560 -- Prevent the search from going too far or within the scope
4561 -- space of another unit.
4563 if Scope
.Entity
= Standard_Standard
then
4566 -- No transient scope should be encountered during the
4567 -- traversal because Establish_Transient_Scope should have
4568 -- already handled this case.
4570 elsif Scope
.Is_Transient
then
4571 raise Program_Error
;
4573 -- The construct that requires secondary stack management is
4574 -- always enclosed by a package or subprogram scope.
4576 elsif Is_Package_Or_Subprogram
(Scope
.Entity
) then
4577 Set_Uses_Sec_Stack
(Scope
.Entity
);
4578 Check_Restriction
(No_Secondary_Stack
, N
);
4585 -- At this point no suitable scope was found. This should never occur
4586 -- because a construct is always enclosed by a compilation unit which
4589 pragma Assert
(False);
4590 end Delegate_Sec_Stack_Management
;
4592 ------------------------------------
4593 -- Find_Enclosing_Transient_Scope --
4594 ------------------------------------
4596 function Find_Enclosing_Transient_Scope
return Int
is
4598 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4600 Scope
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Index
);
4602 -- Prevent the search from going too far or within the scope
4603 -- space of another unit.
4605 if Scope
.Entity
= Standard_Standard
4606 or else Is_Package_Or_Subprogram
(Scope
.Entity
)
4610 elsif Scope
.Is_Transient
then
4617 end Find_Enclosing_Transient_Scope
;
4619 ----------------------------
4620 -- Find_Transient_Context --
4621 ----------------------------
4623 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
4624 Curr
: Node_Id
:= N
;
4625 Prev
: Node_Id
:= Empty
;
4628 while Present
(Curr
) loop
4629 case Nkind
(Curr
) is
4633 -- Declarations act as a boundary for a transient scope even if
4634 -- they are not wrapped, see Wrap_Transient_Declaration.
4636 when N_Object_Declaration
4637 | N_Object_Renaming_Declaration
4638 | N_Subtype_Declaration
4644 -- Statements and statement-like constructs act as a boundary
4645 -- for a transient scope.
4647 when N_Accept_Alternative
4648 | N_Attribute_Definition_Clause
4650 | N_Case_Statement_Alternative
4652 | N_Delay_Alternative
4653 | N_Delay_Until_Statement
4654 | N_Delay_Relative_Statement
4655 | N_Discriminant_Association
4657 | N_Entry_Body_Formal_Part
4660 | N_Iteration_Scheme
4661 | N_Terminate_Alternative
4663 pragma Assert
(Present
(Prev
));
4666 when N_Assignment_Statement
=>
4669 when N_Entry_Call_Statement
4670 | N_Procedure_Call_Statement
4672 -- When an entry or procedure call acts as the alternative
4673 -- of a conditional or timed entry call, the proper context
4674 -- is that of the alternative.
4676 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
4677 and then Nkind
(Parent
(Parent
(Curr
))) in
4678 N_Conditional_Entry_Call | N_Timed_Entry_Call
4680 return Parent
(Parent
(Curr
));
4682 -- General case for entry or procedure calls
4690 -- Pragma Check is not a valid transient context in
4691 -- GNATprove mode because the pragma must remain unchanged.
4694 and then Get_Pragma_Id
(Curr
) = Pragma_Check
4698 -- General case for pragmas
4704 when N_Raise_Statement
=>
4707 when N_Simple_Return_Statement
=>
4709 Fun_Id
: constant Entity_Id
:=
4710 Return_Applies_To
(Return_Statement_Entity
(Curr
));
4713 -- A transient context that must manage the secondary
4714 -- stack cannot be a return statement of a function that
4715 -- itself requires secondary stack management, because
4716 -- the function's result would be reclaimed too early.
4717 -- And returns of thunks never require transient scopes.
4719 if (Manage_Sec_Stack
4720 and then Needs_Secondary_Stack
(Etype
(Fun_Id
)))
4721 or else Is_Thunk
(Fun_Id
)
4725 -- General case for return statements
4734 when N_Attribute_Reference
=>
4735 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
4739 -- An Ada 2012 iterator specification is not a valid context
4740 -- because Analyze_Iterator_Specification already employs
4741 -- special processing for it.
4743 when N_Iterator_Specification
=>
4746 when N_Loop_Parameter_Specification
=>
4748 -- An iteration scheme is not a valid context because
4749 -- routine Analyze_Iteration_Scheme already employs
4750 -- special processing.
4752 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
4755 return Parent
(Curr
);
4760 -- The following nodes represent "dummy contexts" which do not
4761 -- need to be wrapped.
4763 when N_Component_Declaration
4764 | N_Discriminant_Specification
4765 | N_Parameter_Specification
4769 -- If the traversal leaves a scope without having been able to
4770 -- find a construct to wrap, something is going wrong, but this
4771 -- can happen in error situations that are not detected yet
4772 -- (such as a dynamic string in a pragma Export).
4774 when N_Block_Statement
4777 | N_Package_Declaration
4791 Curr
:= Parent
(Curr
);
4795 end Find_Transient_Context
;
4797 ------------------------------
4798 -- Is_Package_Or_Subprogram --
4799 ------------------------------
4801 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4803 return Ekind
(Id
) in E_Entry
4808 | E_Subprogram_Body
;
4809 end Is_Package_Or_Subprogram
;
4813 Trans_Idx
: constant Int
:= Find_Enclosing_Transient_Scope
;
4816 -- Start of processing for Establish_Transient_Scope
4819 -- Do not create a new transient scope if there is already an enclosing
4820 -- transient scope within the innermost enclosing package or subprogram.
4822 if Trans_Idx
>= 0 then
4824 -- If the transient scope was requested for purposes of managing the
4825 -- secondary stack, then the existing scope must perform this task,
4826 -- unless the node to be wrapped is a return statement of a function
4827 -- that requires secondary stack management, because the function's
4828 -- result would be reclaimed too early (see Find_Transient_Context).
4830 if Manage_Sec_Stack
then
4832 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Trans_Idx
);
4835 if Nkind
(SE
.Node_To_Be_Wrapped
) /= N_Simple_Return_Statement
4837 Needs_Secondary_Stack
4840 (Return_Statement_Entity
(SE
.Node_To_Be_Wrapped
))))
4842 Set_Uses_Sec_Stack
(SE
.Entity
);
4850 -- Find the construct that must be serviced by a new transient scope, if
4853 Context
:= Find_Transient_Context
(N
);
4855 if Present
(Context
) then
4856 if Nkind
(Context
) = N_Assignment_Statement
then
4858 -- An assignment statement with suppressed controlled semantics
4859 -- does not need a transient scope because finalization is not
4860 -- desirable at this point. Note that No_Ctrl_Actions is also
4861 -- set for non-controlled assignments to suppress dispatching
4864 if No_Ctrl_Actions
(Context
)
4865 and then Needs_Finalization
(Etype
(Name
(Context
)))
4867 -- When a controlled component is initialized by a function
4868 -- call, the result on the secondary stack is always assigned
4869 -- to the component. Signal the nearest suitable scope that it
4870 -- is safe to manage the secondary stack.
4872 if Manage_Sec_Stack
and then Within_Init_Proc
then
4873 Delegate_Sec_Stack_Management
;
4876 -- Otherwise the assignment is a normal transient context and thus
4877 -- requires a transient scope.
4880 Create_Transient_Scope
(Context
);
4886 Create_Transient_Scope
(Context
);
4889 end Establish_Transient_Scope
;
4891 ----------------------------
4892 -- Expand_Cleanup_Actions --
4893 ----------------------------
4895 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4897 (Nkind
(N
) in N_Block_Statement
4901 | N_Extended_Return_Statement
);
4903 Scop
: constant Entity_Id
:= Current_Scope
;
4905 Is_Asynchronous_Call
: constant Boolean :=
4906 Nkind
(N
) = N_Block_Statement
4907 and then Is_Asynchronous_Call_Block
(N
);
4908 Is_Master
: constant Boolean :=
4909 Nkind
(N
) /= N_Extended_Return_Statement
4910 and then Nkind
(N
) /= N_Entry_Body
4911 and then Is_Task_Master
(N
);
4912 Is_Protected_Subp_Body
: constant Boolean :=
4913 Nkind
(N
) = N_Subprogram_Body
4914 and then Is_Protected_Subprogram_Body
(N
);
4915 Is_Task_Allocation
: constant Boolean :=
4916 Nkind
(N
) = N_Block_Statement
4917 and then Is_Task_Allocation_Block
(N
);
4918 Is_Task_Body
: constant Boolean :=
4919 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4921 -- We mark the secondary stack if it is used in this construct, and
4922 -- we're not returning a function result on the secondary stack, except
4923 -- that a build-in-place function that might or might not return on the
4924 -- secondary stack always needs a mark. A run-time test is required in
4925 -- the case where the build-in-place function has a BIP_Alloc extra
4926 -- parameter (see Create_Finalizer).
4928 Needs_Sec_Stack_Mark
: constant Boolean :=
4929 (Uses_Sec_Stack
(Scop
)
4931 not Sec_Stack_Needed_For_Return
(Scop
))
4933 (Is_Build_In_Place_Function
(Scop
)
4934 and then Needs_BIP_Alloc_Form
(Scop
));
4936 Needs_Custom_Cleanup
: constant Boolean :=
4937 Nkind
(N
) = N_Block_Statement
4938 and then Present
(Cleanup_Actions
(N
));
4940 Actions_Required
: constant Boolean :=
4941 Requires_Cleanup_Actions
(N
, True)
4942 or else Is_Asynchronous_Call
4944 or else Is_Protected_Subp_Body
4945 or else Is_Task_Allocation
4946 or else Is_Task_Body
4947 or else Needs_Sec_Stack_Mark
4948 or else Needs_Custom_Cleanup
;
4953 -- Start of processing for Expand_Cleanup_Actions
4956 -- The current construct does not need any form of servicing
4958 if not Actions_Required
then
4962 -- If an extended return statement contains something like
4966 -- where F is a build-in-place function call returning a controlled
4967 -- type, then a temporary object will be implicitly declared as part
4968 -- of the statement list, and this will need cleanup. In such cases,
4971 -- return Result : T := ... do
4972 -- <statements> -- possibly with handlers
4977 -- return Result : T := ... do
4978 -- declare -- no declarations
4980 -- <statements> -- possibly with handlers
4981 -- end; -- no handlers
4984 -- So Expand_Cleanup_Actions will end up being called recursively on the
4987 if Nkind
(N
) = N_Extended_Return_Statement
then
4989 Block
: constant Node_Id
:=
4990 Make_Block_Statement
(Sloc
(N
),
4991 Declarations
=> Empty_List
,
4992 Handled_Statement_Sequence
=>
4993 Handled_Statement_Sequence
(N
));
4995 Set_Handled_Statement_Sequence
(N
,
4996 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
4997 Statements
=> New_List
(Block
)));
5002 -- Analysis of the block did all the work
5007 if Needs_Custom_Cleanup
then
5008 Cln
:= Cleanup_Actions
(N
);
5013 if No
(Declarations
(N
)) then
5014 Set_Declarations
(N
, New_List
);
5018 Decls
: constant List_Id
:= Declarations
(N
);
5020 Mark
: Entity_Id
:= Empty
;
5022 -- If we are generating expanded code for debugging purposes, use the
5023 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5024 -- be updated subsequently to reference the proper line in .dg files.
5025 -- If we are not debugging generated code, use No_Location instead,
5026 -- so that no debug information is generated for the cleanup code.
5027 -- This makes the behavior of the NEXT command in GDB monotonic, and
5028 -- makes the placement of breakpoints more accurate.
5030 if Debug_Generated_Code
then
5036 -- A task activation call has already been built for a task
5037 -- allocation block.
5039 if not Is_Task_Allocation
then
5040 Build_Task_Activation_Call
(N
);
5044 Establish_Task_Master
(N
);
5047 -- If secondary stack is in use, generate:
5049 -- Mnn : constant Mark_Id := SS_Mark;
5051 if Needs_Sec_Stack_Mark
then
5052 Set_Uses_Sec_Stack
(Scop
, False); -- avoid duplicate SS marks
5053 Mark
:= Make_Temporary
(Loc
, 'M');
5056 Mark_Call
: constant Node_Id
:= Build_SS_Mark_Call
(Loc
, Mark
);
5058 Prepend_To
(Decls
, Mark_Call
);
5059 Analyze
(Mark_Call
);
5063 -- Generate finalization calls for all controlled objects appearing
5064 -- in the statements of N. Add context specific cleanup for various
5069 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
5072 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
5076 if Present
(Fin_Id
) then
5077 Build_Finalizer_Call
(N
, Fin_Id
);
5080 end Expand_Cleanup_Actions
;
5082 ---------------------------
5083 -- Expand_N_Package_Body --
5084 ---------------------------
5086 -- Add call to Activate_Tasks if body is an activator (actual processing
5087 -- is in chapter 9).
5089 -- Generate subprogram descriptor for elaboration routine
5091 -- Encode entity names in package body
5093 procedure Expand_N_Package_Body
(N
: Node_Id
) is
5094 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5095 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
5100 -- This is done only for non-generic packages
5102 if Ekind
(Spec_Id
) = E_Package
then
5103 -- Build dispatch tables of library-level tagged types for bodies
5104 -- that are not compilation units (see Analyze_Compilation_Unit),
5105 -- except for instances because they have no N_Compilation_Unit.
5107 if Tagged_Type_Expansion
5108 and then Is_Library_Level_Entity
(Spec_Id
)
5109 and then (not Is_Compilation_Unit
(Spec_Id
)
5110 or else Is_Generic_Instance
(Spec_Id
))
5112 Build_Static_Dispatch_Tables
(N
);
5115 Push_Scope
(Spec_Id
);
5117 Expand_CUDA_Package
(N
);
5119 Build_Task_Activation_Call
(N
);
5121 -- Verify the run-time semantics of pragma Initial_Condition at the
5122 -- end of the body statements.
5124 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
5126 -- If this is a library-level package and unnesting is enabled,
5127 -- check for the presence of blocks with nested subprograms occurring
5128 -- in elaboration code, and generate procedures to encapsulate the
5129 -- blocks in case the nested subprograms make up-level references.
5131 if Unnest_Subprogram_Mode
5133 Is_Library_Level_Entity
(Current_Scope
)
5135 Check_Unnesting_Elaboration_Code
(N
);
5136 Check_Unnesting_In_Decls_Or_Stmts
(Declarations
(N
));
5137 Check_Unnesting_In_Handlers
(N
);
5143 Set_Elaboration_Flag
(N
, Spec_Id
);
5144 Set_In_Package_Body
(Spec_Id
, False);
5146 -- Set to encode entity names in package body before gigi is called
5148 Qualify_Entity_Names
(N
);
5150 if Ekind
(Spec_Id
) /= E_Generic_Package
5151 and then not Delay_Cleanups
(Id
)
5155 Clean_Stmts
=> No_List
,
5157 Top_Decls
=> No_List
,
5158 Defer_Abort
=> False,
5161 if Present
(Fin_Id
) then
5162 Set_Finalizer
(Defining_Entity
(N
), Fin_Id
);
5165 end Expand_N_Package_Body
;
5167 ----------------------------------
5168 -- Expand_N_Package_Declaration --
5169 ----------------------------------
5171 -- Add call to Activate_Tasks if there are tasks declared and the package
5172 -- has no body. Note that in Ada 83 this may result in premature activation
5173 -- of some tasks, given that we cannot tell whether a body will eventually
5176 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
5177 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5178 Spec
: constant Node_Id
:= Specification
(N
);
5182 No_Body
: Boolean := False;
5183 -- True in the case of a package declaration that is a compilation
5184 -- unit and for which no associated body will be compiled in this
5188 -- Case of a package declaration other than a compilation unit
5190 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
5193 -- Case of a compilation unit that does not require a body
5195 elsif not Body_Required
(Parent
(N
))
5196 and then not Unit_Requires_Body
(Id
)
5200 -- Special case of generating calling stubs for a remote call interface
5201 -- package: even though the package declaration requires one, the body
5202 -- won't be processed in this compilation (so any stubs for RACWs
5203 -- declared in the package must be generated here, along with the spec).
5205 elsif Parent
(N
) = Cunit
(Main_Unit
)
5206 and then Is_Remote_Call_Interface
(Id
)
5207 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
5212 -- For a nested instance, delay processing until freeze point
5214 if Has_Delayed_Freeze
(Id
)
5215 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
5220 -- For a package declaration that implies no associated body, generate
5221 -- task activation call and RACW supporting bodies now (since we won't
5222 -- have a specific separate compilation unit for that).
5227 -- Generate RACW subprogram bodies
5229 if Has_RACW
(Id
) then
5230 Decls
:= Private_Declarations
(Spec
);
5233 Decls
:= Visible_Declarations
(Spec
);
5238 Set_Visible_Declarations
(Spec
, Decls
);
5241 Append_RACW_Bodies
(Decls
, Id
);
5242 Analyze_List
(Decls
);
5245 -- Generate task activation call as last step of elaboration
5247 if Present
(Activation_Chain_Entity
(N
)) then
5248 Build_Task_Activation_Call
(N
);
5251 -- Verify the run-time semantics of pragma Initial_Condition at the
5252 -- end of the private declarations when the package lacks a body.
5254 Expand_Pragma_Initial_Condition
(Id
, N
);
5259 -- Build dispatch tables of library-level tagged types for instances
5260 -- that are not compilation units (see Analyze_Compilation_Unit).
5262 if Tagged_Type_Expansion
5263 and then Is_Library_Level_Entity
(Id
)
5264 and then Is_Generic_Instance
(Id
)
5265 and then not Is_Compilation_Unit
(Id
)
5267 Build_Static_Dispatch_Tables
(N
);
5270 -- Note: it is not necessary to worry about generating a subprogram
5271 -- descriptor, since the only way to get exception handlers into a
5272 -- package spec is to include instantiations, and that would cause
5273 -- generation of subprogram descriptors to be delayed in any case.
5275 -- Set to encode entity names in package spec before gigi is called
5277 Qualify_Entity_Names
(N
);
5279 if Ekind
(Id
) /= E_Generic_Package
5280 and then not Delay_Cleanups
(Id
)
5284 Clean_Stmts
=> No_List
,
5286 Top_Decls
=> No_List
,
5287 Defer_Abort
=> False,
5290 if Present
(Fin_Id
) then
5291 Set_Finalizer
(Id
, Fin_Id
);
5295 -- If this is a library-level package and unnesting is enabled,
5296 -- check for the presence of blocks with nested subprograms occurring
5297 -- in elaboration code, and generate procedures to encapsulate the
5298 -- blocks in case the nested subprograms make up-level references.
5300 if Unnest_Subprogram_Mode
5301 and then Is_Library_Level_Entity
(Current_Scope
)
5303 Check_Unnesting_In_Decls_Or_Stmts
(Visible_Declarations
(Spec
));
5304 Check_Unnesting_In_Decls_Or_Stmts
(Private_Declarations
(Spec
));
5306 end Expand_N_Package_Declaration
;
5308 ---------------------------------
5309 -- Has_Simple_Protected_Object --
5310 ---------------------------------
5312 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5314 if Has_Task
(T
) then
5317 elsif Is_Simple_Protected_Type
(T
) then
5320 elsif Is_Array_Type
(T
) then
5321 return Has_Simple_Protected_Object
(Component_Type
(T
));
5323 elsif Is_Record_Type
(T
) then
5328 Comp
:= First_Component
(T
);
5329 while Present
(Comp
) loop
5330 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5334 Next_Component
(Comp
);
5343 end Has_Simple_Protected_Object
;
5345 ------------------------------------
5346 -- Insert_Actions_In_Scope_Around --
5347 ------------------------------------
5349 procedure Insert_Actions_In_Scope_Around
5352 Manage_SS
: Boolean)
5354 Act_Before
: constant List_Id
:=
5355 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5356 Act_After
: constant List_Id
:=
5357 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5358 Act_Cleanup
: constant List_Id
:=
5359 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5360 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5361 -- Last), but this was incorrect as Process_Transients_In_Scope may
5362 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5364 procedure Process_Transients_In_Scope
5365 (First_Object
: Node_Id
;
5366 Last_Object
: Node_Id
;
5367 Related_Node
: Node_Id
);
5368 -- Find all transient objects in the list First_Object .. Last_Object
5369 -- and generate finalization actions for them. Related_Node denotes the
5370 -- node which created all transient objects.
5372 ---------------------------------
5373 -- Process_Transients_In_Scope --
5374 ---------------------------------
5376 procedure Process_Transients_In_Scope
5377 (First_Object
: Node_Id
;
5378 Last_Object
: Node_Id
;
5379 Related_Node
: Node_Id
)
5381 Must_Hook
: Boolean;
5382 -- Flag denoting whether the context requires transient object
5383 -- export to the outer finalizer.
5385 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5386 -- Return Abandon if arbitrary node denotes a subprogram call
5388 function Has_Subprogram_Call
is
5389 new Traverse_Func
(Is_Subprogram_Call
);
5391 procedure Process_Transient_In_Scope
5392 (Obj_Decl
: Node_Id
;
5393 Blk_Data
: Finalization_Exception_Data
;
5394 Blk_Stmts
: List_Id
);
5395 -- Generate finalization actions for a single transient object
5396 -- denoted by object declaration Obj_Decl. Blk_Data is the
5397 -- exception data of the enclosing block. Blk_Stmts denotes the
5398 -- statements of the enclosing block.
5400 ------------------------
5401 -- Is_Subprogram_Call --
5402 ------------------------
5404 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5406 -- A regular procedure or function call
5408 if Nkind
(N
) in N_Subprogram_Call
then
5413 -- Heavy expansion may relocate function calls outside the related
5414 -- node. Inspect the original node to detect the initial placement
5417 elsif Is_Rewrite_Substitution
(N
) then
5418 return Has_Subprogram_Call
(Original_Node
(N
));
5420 -- Generalized indexing always involves a function call
5422 elsif Nkind
(N
) = N_Indexed_Component
5423 and then Present
(Generalized_Indexing
(N
))
5432 end Is_Subprogram_Call
;
5434 --------------------------------
5435 -- Process_Transient_In_Scope --
5436 --------------------------------
5438 procedure Process_Transient_In_Scope
5439 (Obj_Decl
: Node_Id
;
5440 Blk_Data
: Finalization_Exception_Data
;
5441 Blk_Stmts
: List_Id
)
5443 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5444 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5446 Fin_Stmts
: List_Id
;
5447 Hook_Assign
: Node_Id
;
5448 Hook_Clear
: Node_Id
;
5449 Hook_Decl
: Node_Id
;
5450 Hook_Insert
: Node_Id
;
5454 -- Mark the transient object as successfully processed to avoid
5455 -- double finalization.
5457 Set_Is_Finalized_Transient
(Obj_Id
);
5459 -- Construct all the pieces necessary to hook and finalize the
5460 -- transient object.
5462 Build_Transient_Object_Statements
5463 (Obj_Decl
=> Obj_Decl
,
5464 Fin_Call
=> Fin_Call
,
5465 Hook_Assign
=> Hook_Assign
,
5466 Hook_Clear
=> Hook_Clear
,
5467 Hook_Decl
=> Hook_Decl
,
5468 Ptr_Decl
=> Ptr_Decl
);
5470 -- The context contains at least one subprogram call which may
5471 -- raise an exception. This scenario employs "hooking" to pass
5472 -- transient objects to the enclosing finalizer in case of an
5477 -- Add the access type which provides a reference to the
5478 -- transient object. Generate:
5480 -- type Ptr_Typ is access all Desig_Typ;
5482 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5484 -- Add the temporary which acts as a hook to the transient
5485 -- object. Generate:
5487 -- Hook : Ptr_Typ := null;
5489 Insert_Action
(Obj_Decl
, Hook_Decl
);
5491 -- When the transient object is initialized by an aggregate,
5492 -- the hook must capture the object after the last aggregate
5493 -- assignment takes place. Only then is the object considered
5494 -- fully initialized. Generate:
5496 -- Hook := Ptr_Typ (Obj_Id);
5498 -- Hook := Obj_Id'Unrestricted_Access;
5500 -- Similarly if we have a build in place call: we must
5501 -- initialize Hook only after the call has happened, otherwise
5502 -- Obj_Id will not be initialized yet.
5504 if Ekind
(Obj_Id
) in E_Constant | E_Variable
then
5505 if Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
5506 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5507 elsif Present
(BIP_Initialization_Call
(Obj_Id
)) then
5508 Hook_Insert
:= BIP_Initialization_Call
(Obj_Id
);
5510 Hook_Insert
:= Obj_Decl
;
5513 -- Otherwise the hook seizes the related object immediately
5516 Hook_Insert
:= Obj_Decl
;
5519 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5522 -- When exception propagation is enabled wrap the hook clear
5523 -- statement and the finalization call into a block to catch
5524 -- potential exceptions raised during finalization. Generate:
5528 -- [Deep_]Finalize (Obj_Ref);
5532 -- if not Raised then
5535 -- (Enn, Get_Current_Excep.all.all);
5539 if Exceptions_OK
then
5540 Fin_Stmts
:= New_List
;
5543 Append_To
(Fin_Stmts
, Hook_Clear
);
5546 Append_To
(Fin_Stmts
, Fin_Call
);
5548 Prepend_To
(Blk_Stmts
,
5549 Make_Block_Statement
(Loc
,
5550 Handled_Statement_Sequence
=>
5551 Make_Handled_Sequence_Of_Statements
(Loc
,
5552 Statements
=> Fin_Stmts
,
5553 Exception_Handlers
=> New_List
(
5554 Build_Exception_Handler
(Blk_Data
)))));
5556 -- Otherwise generate:
5559 -- [Deep_]Finalize (Obj_Ref);
5561 -- Note that the statements are inserted in reverse order to
5562 -- achieve the desired final order outlined above.
5565 Prepend_To
(Blk_Stmts
, Fin_Call
);
5568 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5571 end Process_Transient_In_Scope
;
5575 Built
: Boolean := False;
5576 Blk_Data
: Finalization_Exception_Data
;
5577 Blk_Decl
: Node_Id
:= Empty
;
5578 Blk_Decls
: List_Id
:= No_List
;
5580 Blk_Stmts
: List_Id
:= No_List
;
5581 Loc
: Source_Ptr
:= No_Location
;
5584 -- Start of processing for Process_Transients_In_Scope
5587 -- The expansion performed by this routine is as follows:
5589 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5590 -- Hook_1 : Ptr_Typ_1 := null;
5591 -- Ctrl_Trans_Obj_1 : ...;
5592 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5594 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5595 -- Hook_N : Ptr_Typ_N := null;
5596 -- Ctrl_Trans_Obj_N : ...;
5597 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5600 -- Abrt : constant Boolean := ...;
5601 -- Ex : Exception_Occurrence;
5602 -- Raised : Boolean := False;
5609 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5613 -- if not Raised then
5615 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5620 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5624 -- if not Raised then
5626 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5631 -- if Raised and not Abrt then
5632 -- Raise_From_Controlled_Operation (Ex);
5636 -- Recognize a scenario where the transient context is an object
5637 -- declaration initialized by a build-in-place function call:
5639 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5641 -- The rough expansion of the above is:
5643 -- Temp : ... := Ctrl_Func_Call;
5645 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5647 -- The finalization of any transient object must happen after the
5648 -- build-in-place function call is executed.
5650 if Nkind
(N
) = N_Object_Declaration
5651 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5654 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5656 -- Search the context for at least one subprogram call. If found, the
5657 -- machinery exports all transient objects to the enclosing finalizer
5658 -- due to the possibility of abnormal call termination.
5661 Must_Hook
:= Has_Subprogram_Call
(N
) = Abandon
;
5662 Blk_Ins
:= Last_Object
;
5666 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5669 -- Examine all objects in the list First_Object .. Last_Object
5671 Obj_Decl
:= First_Object
;
5672 while Present
(Obj_Decl
) loop
5673 if Nkind
(Obj_Decl
) = N_Object_Declaration
5674 and then Analyzed
(Obj_Decl
)
5675 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5677 -- Do not process the node to be wrapped since it will be
5678 -- handled by the enclosing finalizer.
5680 and then Obj_Decl
/= Related_Node
5682 Loc
:= Sloc
(Obj_Decl
);
5684 -- Before generating the cleanup code for the first transient
5685 -- object, create a wrapper block which houses all hook clear
5686 -- statements and finalization calls. This wrapper is needed by
5691 Blk_Stmts
:= New_List
;
5694 -- Abrt : constant Boolean := ...;
5695 -- Ex : Exception_Occurrence;
5696 -- Raised : Boolean := False;
5698 if Exceptions_OK
then
5699 Blk_Decls
:= New_List
;
5700 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5704 Make_Block_Statement
(Loc
,
5705 Declarations
=> Blk_Decls
,
5706 Handled_Statement_Sequence
=>
5707 Make_Handled_Sequence_Of_Statements
(Loc
,
5708 Statements
=> Blk_Stmts
));
5711 -- Construct all necessary circuitry to hook and finalize a
5712 -- single transient object.
5714 pragma Assert
(Present
(Blk_Stmts
));
5715 Process_Transient_In_Scope
5716 (Obj_Decl
=> Obj_Decl
,
5717 Blk_Data
=> Blk_Data
,
5718 Blk_Stmts
=> Blk_Stmts
);
5721 -- Terminate the scan after the last object has been processed to
5722 -- avoid touching unrelated code.
5724 if Obj_Decl
= Last_Object
then
5731 -- Complete the decoration of the enclosing finalization block and
5732 -- insert it into the tree.
5734 if Present
(Blk_Decl
) then
5736 pragma Assert
(Present
(Blk_Stmts
));
5737 pragma Assert
(Loc
/= No_Location
);
5739 -- Note that this Abort_Undefer does not require a extra block or
5740 -- an AT_END handler because each finalization exception is caught
5741 -- in its own corresponding finalization block. As a result, the
5742 -- call to Abort_Defer always takes place.
5744 if Abort_Allowed
then
5745 Prepend_To
(Blk_Stmts
,
5746 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5748 Append_To
(Blk_Stmts
,
5749 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5753 -- if Raised and then not Abrt then
5754 -- Raise_From_Controlled_Operation (Ex);
5757 if Exceptions_OK
then
5758 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5761 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5763 end Process_Transients_In_Scope
;
5767 Loc
: constant Source_Ptr
:= Sloc
(N
);
5768 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5769 First_Obj
: Node_Id
;
5771 Mark_Id
: Entity_Id
;
5774 -- Start of processing for Insert_Actions_In_Scope_Around
5777 -- Nothing to do if the scope does not manage the secondary stack or
5778 -- does not contain meaningful actions for insertion.
5781 and then No
(Act_Before
)
5782 and then No
(Act_After
)
5783 and then No
(Act_Cleanup
)
5788 -- If the node to be wrapped is the trigger of an asynchronous select,
5789 -- it is not part of a statement list. The actions must be inserted
5790 -- before the select itself, which is part of some list of statements.
5791 -- Note that the triggering alternative includes the triggering
5792 -- statement and an optional statement list. If the node to be
5793 -- wrapped is part of that list, the normal insertion applies.
5795 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5796 and then not Is_List_Member
(Node_To_Wrap
)
5798 Target
:= Parent
(Parent
(Node_To_Wrap
));
5803 First_Obj
:= Target
;
5806 -- Add all actions associated with a transient scope into the main tree.
5807 -- There are several scenarios here:
5809 -- +--- Before ----+ +----- After ---+
5810 -- 1) First_Obj ....... Target ........ Last_Obj
5812 -- 2) First_Obj ....... Target
5814 -- 3) Target ........ Last_Obj
5816 -- Flag declarations are inserted before the first object
5818 if Present
(Act_Before
) then
5819 First_Obj
:= First
(Act_Before
);
5820 Insert_List_Before
(Target
, Act_Before
);
5823 -- Finalization calls are inserted after the last object
5825 if Present
(Act_After
) then
5826 Last_Obj
:= Last
(Act_After
);
5827 Insert_List_After
(Target
, Act_After
);
5830 -- Mark and release the secondary stack when the context warrants it
5833 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5836 -- Mnn : constant Mark_Id := SS_Mark;
5838 Insert_Before_And_Analyze
5839 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5842 -- SS_Release (Mnn);
5844 Insert_After_And_Analyze
5845 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5848 -- Check for transient objects associated with Target and generate the
5849 -- appropriate finalization actions for them.
5851 Process_Transients_In_Scope
5852 (First_Object
=> First_Obj
,
5853 Last_Object
=> Last_Obj
,
5854 Related_Node
=> Target
);
5856 -- Reset the action lists
5859 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5861 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5865 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5867 end Insert_Actions_In_Scope_Around
;
5869 ------------------------------
5870 -- Is_Simple_Protected_Type --
5871 ------------------------------
5873 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5876 Is_Protected_Type
(T
)
5877 and then not Uses_Lock_Free
(T
)
5878 and then not Has_Entries
(T
)
5879 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5880 end Is_Simple_Protected_Type
;
5882 -----------------------
5883 -- Make_Adjust_Call --
5884 -----------------------
5886 function Make_Adjust_Call
5889 Skip_Self
: Boolean := False) return Node_Id
5891 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5892 Adj_Id
: Entity_Id
:= Empty
;
5899 -- Recover the proper type which contains Deep_Adjust
5901 if Is_Class_Wide_Type
(Typ
) then
5902 Utyp
:= Root_Type
(Typ
);
5907 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5908 Set_Assignment_OK
(Ref
);
5910 -- Deal with untagged derivation of private views
5912 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5913 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5914 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5915 Set_Assignment_OK
(Ref
);
5918 -- When dealing with the completion of a private type, use the base
5921 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5922 pragma Assert
(Is_Private_Type
(Typ
));
5924 Utyp
:= Base_Type
(Utyp
);
5925 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5928 -- The underlying type may not be present due to a missing full view. In
5929 -- this case freezing did not take place and there is no [Deep_]Adjust
5930 -- primitive to call.
5935 elsif Skip_Self
then
5936 if Has_Controlled_Component
(Utyp
) then
5937 if Is_Tagged_Type
(Utyp
) then
5938 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5940 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5944 -- Class-wide types, interfaces and types with controlled components
5946 elsif Is_Class_Wide_Type
(Typ
)
5947 or else Is_Interface
(Typ
)
5948 or else Has_Controlled_Component
(Utyp
)
5950 if Is_Tagged_Type
(Utyp
) then
5951 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5953 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5956 -- Derivations from [Limited_]Controlled
5958 elsif Is_Controlled
(Utyp
) then
5959 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5963 elsif Is_Tagged_Type
(Utyp
) then
5964 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5967 raise Program_Error
;
5970 if Present
(Adj_Id
) then
5972 -- If the object is unanalyzed, set its expected type for use in
5973 -- Convert_View in case an additional conversion is needed.
5976 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5978 Set_Etype
(Ref
, Typ
);
5981 -- The object reference may need another conversion depending on the
5982 -- type of the formal and that of the actual.
5984 if not Is_Class_Wide_Type
(Typ
) then
5985 Ref
:= Convert_View
(Adj_Id
, Ref
);
5992 Skip_Self
=> Skip_Self
);
5996 end Make_Adjust_Call
;
6004 Proc_Id
: Entity_Id
;
6006 Skip_Self
: Boolean := False) return Node_Id
6008 Params
: constant List_Id
:= New_List
(Param
);
6011 -- Do not apply the controlled action to the object itself by signaling
6012 -- the related routine to avoid self.
6015 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
6019 Make_Procedure_Call_Statement
(Loc
,
6020 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
6021 Parameter_Associations
=> Params
);
6024 --------------------------
6025 -- Make_Deep_Array_Body --
6026 --------------------------
6028 function Make_Deep_Array_Body
6029 (Prim
: Final_Primitives
;
6030 Typ
: Entity_Id
) return List_Id
6032 function Build_Adjust_Or_Finalize_Statements
6033 (Typ
: Entity_Id
) return List_Id
;
6034 -- Create the statements necessary to adjust or finalize an array of
6035 -- controlled elements. Generate:
6038 -- Abort : constant Boolean := Triggered_By_Abort;
6040 -- Abort : constant Boolean := False; -- no abort
6042 -- E : Exception_Occurrence;
6043 -- Raised : Boolean := False;
6046 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6047 -- ^-- in the finalization case
6049 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6051 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6055 -- if not Raised then
6057 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6064 -- if Raised and then not Abort then
6065 -- Raise_From_Controlled_Operation (E);
6069 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
6070 -- Create the statements necessary to initialize an array of controlled
6071 -- elements. Include a mechanism to carry out partial finalization if an
6072 -- exception occurs. Generate:
6075 -- Counter : Integer := 0;
6078 -- for J1 in V'Range (1) loop
6080 -- for JN in V'Range (N) loop
6082 -- [Deep_]Initialize (V (J1, ..., JN));
6084 -- Counter := Counter + 1;
6089 -- Abort : constant Boolean := Triggered_By_Abort;
6091 -- Abort : constant Boolean := False; -- no abort
6092 -- E : Exception_Occurrence;
6093 -- Raised : Boolean := False;
6100 -- V'Length (N) - Counter;
6102 -- for F1 in reverse V'Range (1) loop
6104 -- for FN in reverse V'Range (N) loop
6105 -- if Counter > 0 then
6106 -- Counter := Counter - 1;
6109 -- [Deep_]Finalize (V (F1, ..., FN));
6113 -- if not Raised then
6115 -- Save_Occurrence (E,
6116 -- Get_Current_Excep.all.all);
6125 -- if Raised and then not Abort then
6126 -- Raise_From_Controlled_Operation (E);
6135 function New_References_To
6137 Loc
: Source_Ptr
) return List_Id
;
6138 -- Given a list of defining identifiers, return a list of references to
6139 -- the original identifiers, in the same order as they appear.
6141 -----------------------------------------
6142 -- Build_Adjust_Or_Finalize_Statements --
6143 -----------------------------------------
6145 function Build_Adjust_Or_Finalize_Statements
6146 (Typ
: Entity_Id
) return List_Id
6148 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6149 Index_List
: constant List_Id
:= New_List
;
6150 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6151 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6153 procedure Build_Indexes
;
6154 -- Generate the indexes used in the dimension loops
6160 procedure Build_Indexes
is
6162 -- Generate the following identifiers:
6163 -- Jnn - for initialization
6165 for Dim
in 1 .. Num_Dims
loop
6166 Append_To
(Index_List
,
6167 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6173 Final_Decls
: List_Id
:= No_List
;
6174 Final_Data
: Finalization_Exception_Data
;
6178 Core_Loop
: Node_Id
;
6181 Loop_Id
: Entity_Id
;
6184 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6187 Final_Decls
:= New_List
;
6190 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6193 Make_Indexed_Component
(Loc
,
6194 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6195 Expressions
=> New_References_To
(Index_List
, Loc
));
6196 Set_Etype
(Comp_Ref
, Comp_Typ
);
6199 -- [Deep_]Adjust (V (J1, ..., JN))
6201 if Prim
= Adjust_Case
then
6202 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6205 -- [Deep_]Finalize (V (J1, ..., JN))
6207 else pragma Assert
(Prim
= Finalize_Case
);
6208 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6211 if Present
(Call
) then
6213 -- Generate the block which houses the adjust or finalize call:
6216 -- <adjust or finalize call>
6220 -- if not Raised then
6222 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6226 if Exceptions_OK
then
6228 Make_Block_Statement
(Loc
,
6229 Handled_Statement_Sequence
=>
6230 Make_Handled_Sequence_Of_Statements
(Loc
,
6231 Statements
=> New_List
(Call
),
6232 Exception_Handlers
=> New_List
(
6233 Build_Exception_Handler
(Final_Data
))));
6238 -- Generate the dimension loops starting from the innermost one
6240 -- for Jnn in [reverse] V'Range (Dim) loop
6244 J
:= Last
(Index_List
);
6246 while Present
(J
) and then Dim
> 0 loop
6252 Make_Loop_Statement
(Loc
,
6254 Make_Iteration_Scheme
(Loc
,
6255 Loop_Parameter_Specification
=>
6256 Make_Loop_Parameter_Specification
(Loc
,
6257 Defining_Identifier
=> Loop_Id
,
6258 Discrete_Subtype_Definition
=>
6259 Make_Attribute_Reference
(Loc
,
6260 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6261 Attribute_Name
=> Name_Range
,
6262 Expressions
=> New_List
(
6263 Make_Integer_Literal
(Loc
, Dim
))),
6266 Prim
= Finalize_Case
)),
6268 Statements
=> New_List
(Core_Loop
),
6269 End_Label
=> Empty
);
6274 -- Generate the block which contains the core loop, declarations
6275 -- of the abort flag, the exception occurrence, the raised flag
6276 -- and the conditional raise:
6279 -- Abort : constant Boolean := Triggered_By_Abort;
6281 -- Abort : constant Boolean := False; -- no abort
6283 -- E : Exception_Occurrence;
6284 -- Raised : Boolean := False;
6289 -- if Raised and then not Abort then
6290 -- Raise_From_Controlled_Operation (E);
6294 Stmts
:= New_List
(Core_Loop
);
6296 if Exceptions_OK
then
6297 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6301 Make_Block_Statement
(Loc
,
6302 Declarations
=> Final_Decls
,
6303 Handled_Statement_Sequence
=>
6304 Make_Handled_Sequence_Of_Statements
(Loc
,
6305 Statements
=> Stmts
));
6307 -- Otherwise previous errors or a missing full view may prevent the
6308 -- proper freezing of the component type. If this is the case, there
6309 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6312 Block
:= Make_Null_Statement
(Loc
);
6315 return New_List
(Block
);
6316 end Build_Adjust_Or_Finalize_Statements
;
6318 ---------------------------------
6319 -- Build_Initialize_Statements --
6320 ---------------------------------
6322 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6323 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6324 Final_List
: constant List_Id
:= New_List
;
6325 Index_List
: constant List_Id
:= New_List
;
6326 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6327 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6329 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6330 -- Generate the following assignment:
6331 -- Counter := V'Length (1) *
6333 -- V'Length (N) - Counter;
6335 -- Counter_Id denotes the entity of the counter.
6337 function Build_Finalization_Call
return Node_Id
;
6338 -- Generate a deep finalization call for an array element
6340 procedure Build_Indexes
;
6341 -- Generate the initialization and finalization indexes used in the
6344 function Build_Initialization_Call
return Node_Id
;
6345 -- Generate a deep initialization call for an array element
6347 ----------------------
6348 -- Build_Assignment --
6349 ----------------------
6351 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6356 -- Start from the first dimension and generate:
6361 Make_Attribute_Reference
(Loc
,
6362 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6363 Attribute_Name
=> Name_Length
,
6364 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6366 -- Process the rest of the dimensions, generate:
6367 -- Expr * V'Length (N)
6370 while Dim
<= Num_Dims
loop
6372 Make_Op_Multiply
(Loc
,
6375 Make_Attribute_Reference
(Loc
,
6376 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6377 Attribute_Name
=> Name_Length
,
6378 Expressions
=> New_List
(
6379 Make_Integer_Literal
(Loc
, Dim
))));
6385 -- Counter := Expr - Counter;
6388 Make_Assignment_Statement
(Loc
,
6389 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6391 Make_Op_Subtract
(Loc
,
6393 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6394 end Build_Assignment
;
6396 -----------------------------
6397 -- Build_Finalization_Call --
6398 -----------------------------
6400 function Build_Finalization_Call
return Node_Id
is
6401 Comp_Ref
: constant Node_Id
:=
6402 Make_Indexed_Component
(Loc
,
6403 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6404 Expressions
=> New_References_To
(Final_List
, Loc
));
6407 Set_Etype
(Comp_Ref
, Comp_Typ
);
6410 -- [Deep_]Finalize (V);
6412 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6413 end Build_Finalization_Call
;
6419 procedure Build_Indexes
is
6421 -- Generate the following identifiers:
6422 -- Jnn - for initialization
6423 -- Fnn - for finalization
6425 for Dim
in 1 .. Num_Dims
loop
6426 Append_To
(Index_List
,
6427 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6429 Append_To
(Final_List
,
6430 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6434 -------------------------------
6435 -- Build_Initialization_Call --
6436 -------------------------------
6438 function Build_Initialization_Call
return Node_Id
is
6439 Comp_Ref
: constant Node_Id
:=
6440 Make_Indexed_Component
(Loc
,
6441 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6442 Expressions
=> New_References_To
(Index_List
, Loc
));
6445 Set_Etype
(Comp_Ref
, Comp_Typ
);
6448 -- [Deep_]Initialize (V (J1, ..., JN));
6450 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6451 end Build_Initialization_Call
;
6455 Counter_Id
: Entity_Id
;
6459 Final_Block
: Node_Id
;
6460 Final_Data
: Finalization_Exception_Data
;
6461 Final_Decls
: List_Id
:= No_List
;
6462 Final_Loop
: Node_Id
;
6463 Init_Block
: Node_Id
;
6464 Init_Call
: Node_Id
;
6465 Init_Loop
: Node_Id
;
6470 -- Start of processing for Build_Initialize_Statements
6473 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6474 Final_Decls
:= New_List
;
6477 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6479 -- Generate the block which houses the finalization call, the index
6480 -- guard and the handler which triggers Program_Error later on.
6482 -- if Counter > 0 then
6483 -- Counter := Counter - 1;
6486 -- [Deep_]Finalize (V (F1, ..., FN));
6489 -- if not Raised then
6491 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6496 Fin_Stmt
:= Build_Finalization_Call
;
6498 if Present
(Fin_Stmt
) then
6499 if Exceptions_OK
then
6501 Make_Block_Statement
(Loc
,
6502 Handled_Statement_Sequence
=>
6503 Make_Handled_Sequence_Of_Statements
(Loc
,
6504 Statements
=> New_List
(Fin_Stmt
),
6505 Exception_Handlers
=> New_List
(
6506 Build_Exception_Handler
(Final_Data
))));
6509 -- This is the core of the loop, the dimension iterators are added
6510 -- one by one in reverse.
6513 Make_If_Statement
(Loc
,
6516 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6517 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6519 Then_Statements
=> New_List
(
6520 Make_Assignment_Statement
(Loc
,
6521 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6523 Make_Op_Subtract
(Loc
,
6524 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6525 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6527 Else_Statements
=> New_List
(Fin_Stmt
));
6529 -- Generate all finalization loops starting from the innermost
6532 -- for Fnn in reverse V'Range (Dim) loop
6536 F
:= Last
(Final_List
);
6538 while Present
(F
) and then Dim
> 0 loop
6544 Make_Loop_Statement
(Loc
,
6546 Make_Iteration_Scheme
(Loc
,
6547 Loop_Parameter_Specification
=>
6548 Make_Loop_Parameter_Specification
(Loc
,
6549 Defining_Identifier
=> Loop_Id
,
6550 Discrete_Subtype_Definition
=>
6551 Make_Attribute_Reference
(Loc
,
6552 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6553 Attribute_Name
=> Name_Range
,
6554 Expressions
=> New_List
(
6555 Make_Integer_Literal
(Loc
, Dim
))),
6557 Reverse_Present
=> True)),
6559 Statements
=> New_List
(Final_Loop
),
6560 End_Label
=> Empty
);
6565 -- Generate the block which contains the finalization loops, the
6566 -- declarations of the abort flag, the exception occurrence, the
6567 -- raised flag and the conditional raise.
6570 -- Abort : constant Boolean := Triggered_By_Abort;
6572 -- Abort : constant Boolean := False; -- no abort
6574 -- E : Exception_Occurrence;
6575 -- Raised : Boolean := False;
6581 -- V'Length (N) - Counter;
6585 -- if Raised and then not Abort then
6586 -- Raise_From_Controlled_Operation (E);
6592 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6594 if Exceptions_OK
then
6595 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6596 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6600 Make_Block_Statement
(Loc
,
6601 Declarations
=> Final_Decls
,
6602 Handled_Statement_Sequence
=>
6603 Make_Handled_Sequence_Of_Statements
(Loc
,
6604 Statements
=> Stmts
));
6606 -- Otherwise previous errors or a missing full view may prevent the
6607 -- proper freezing of the component type. If this is the case, there
6608 -- is no [Deep_]Finalize primitive to call.
6611 Final_Block
:= Make_Null_Statement
(Loc
);
6614 -- Generate the block which contains the initialization call and
6615 -- the partial finalization code.
6618 -- [Deep_]Initialize (V (J1, ..., JN));
6620 -- Counter := Counter + 1;
6624 -- <finalization code>
6627 Init_Call
:= Build_Initialization_Call
;
6629 -- Only create finalization block if there is a nontrivial call
6630 -- to initialization or a Default_Initial_Condition check to be
6633 if (Present
(Init_Call
)
6634 and then Nkind
(Init_Call
) /= N_Null_Statement
)
6637 and then not GNATprove_Mode
6638 and then Present
(DIC_Procedure
(Comp_Typ
))
6639 and then not Has_Null_Body
(DIC_Procedure
(Comp_Typ
)))
6642 Init_Stmts
: constant List_Id
:= New_List
;
6645 if Present
(Init_Call
) then
6646 Append_To
(Init_Stmts
, Init_Call
);
6649 if Has_DIC
(Comp_Typ
)
6650 and then Present
(DIC_Procedure
(Comp_Typ
))
6654 Build_DIC_Call
(Loc
,
6655 Make_Indexed_Component
(Loc
,
6656 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6657 Expressions
=> New_References_To
(Index_List
, Loc
)),
6662 Make_Block_Statement
(Loc
,
6663 Handled_Statement_Sequence
=>
6664 Make_Handled_Sequence_Of_Statements
(Loc
,
6665 Statements
=> Init_Stmts
,
6666 Exception_Handlers
=> New_List
(
6667 Make_Exception_Handler
(Loc
,
6668 Exception_Choices
=> New_List
(
6669 Make_Others_Choice
(Loc
)),
6670 Statements
=> New_List
(Final_Block
)))));
6673 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6674 Make_Assignment_Statement
(Loc
,
6675 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6678 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6679 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6681 -- Generate all initialization loops starting from the innermost
6684 -- for Jnn in V'Range (Dim) loop
6688 J
:= Last
(Index_List
);
6690 while Present
(J
) and then Dim
> 0 loop
6696 Make_Loop_Statement
(Loc
,
6698 Make_Iteration_Scheme
(Loc
,
6699 Loop_Parameter_Specification
=>
6700 Make_Loop_Parameter_Specification
(Loc
,
6701 Defining_Identifier
=> Loop_Id
,
6702 Discrete_Subtype_Definition
=>
6703 Make_Attribute_Reference
(Loc
,
6704 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6705 Attribute_Name
=> Name_Range
,
6706 Expressions
=> New_List
(
6707 Make_Integer_Literal
(Loc
, Dim
))))),
6709 Statements
=> New_List
(Init_Loop
),
6710 End_Label
=> Empty
);
6715 -- Generate the block which contains the counter variable and the
6716 -- initialization loops.
6719 -- Counter : Integer := 0;
6725 Make_Block_Statement
(Loc
,
6726 Declarations
=> New_List
(
6727 Make_Object_Declaration
(Loc
,
6728 Defining_Identifier
=> Counter_Id
,
6729 Object_Definition
=>
6730 New_Occurrence_Of
(Standard_Integer
, Loc
),
6731 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6733 Handled_Statement_Sequence
=>
6734 Make_Handled_Sequence_Of_Statements
(Loc
,
6735 Statements
=> New_List
(Init_Loop
)));
6737 if Debug_Generated_Code
then
6738 Set_Debug_Info_Needed
(Counter_Id
);
6741 -- Otherwise previous errors or a missing full view may prevent the
6742 -- proper freezing of the component type. If this is the case, there
6743 -- is no [Deep_]Initialize primitive to call.
6746 Init_Block
:= Make_Null_Statement
(Loc
);
6749 return New_List
(Init_Block
);
6750 end Build_Initialize_Statements
;
6752 -----------------------
6753 -- New_References_To --
6754 -----------------------
6756 function New_References_To
6758 Loc
: Source_Ptr
) return List_Id
6760 Refs
: constant List_Id
:= New_List
;
6765 while Present
(Id
) loop
6766 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6771 end New_References_To
;
6773 -- Start of processing for Make_Deep_Array_Body
6777 when Address_Case
=>
6778 return Make_Finalize_Address_Stmts
(Typ
);
6783 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6785 when Initialize_Case
=>
6786 return Build_Initialize_Statements
(Typ
);
6788 end Make_Deep_Array_Body
;
6790 --------------------
6791 -- Make_Deep_Proc --
6792 --------------------
6794 function Make_Deep_Proc
6795 (Prim
: Final_Primitives
;
6797 Stmts
: List_Id
) return Entity_Id
6799 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6801 Proc_Id
: Entity_Id
;
6804 -- Create the object formal, generate:
6805 -- V : System.Address
6807 if Prim
= Address_Case
then
6808 Formals
:= New_List
(
6809 Make_Parameter_Specification
(Loc
,
6810 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6812 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6819 Formals
:= New_List
(
6820 Make_Parameter_Specification
(Loc
,
6821 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6823 Out_Present
=> True,
6824 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6826 -- F : Boolean := True
6828 if Prim
= Adjust_Case
6829 or else Prim
= Finalize_Case
6832 Make_Parameter_Specification
(Loc
,
6833 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6835 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6837 New_Occurrence_Of
(Standard_True
, Loc
)));
6842 Make_Defining_Identifier
(Loc
,
6843 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6846 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6849 -- exception -- Finalize and Adjust cases only
6850 -- raise Program_Error;
6851 -- end Deep_Initialize / Adjust / Finalize;
6855 -- procedure Finalize_Address (V : System.Address) is
6858 -- end Finalize_Address;
6861 Make_Subprogram_Body
(Loc
,
6863 Make_Procedure_Specification
(Loc
,
6864 Defining_Unit_Name
=> Proc_Id
,
6865 Parameter_Specifications
=> Formals
),
6867 Declarations
=> Empty_List
,
6869 Handled_Statement_Sequence
=>
6870 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6872 -- If there are no calls to component initialization, indicate that
6873 -- the procedure is trivial, so prevent calls to it.
6875 if Is_Empty_List
(Stmts
)
6876 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6878 Set_Is_Trivial_Subprogram
(Proc_Id
);
6884 ---------------------------
6885 -- Make_Deep_Record_Body --
6886 ---------------------------
6888 function Make_Deep_Record_Body
6889 (Prim
: Final_Primitives
;
6891 Is_Local
: Boolean := False) return List_Id
6893 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6894 -- Build the statements necessary to adjust a record type. The type may
6895 -- have discriminants and contain variant parts. Generate:
6899 -- [Deep_]Adjust (V.Comp_1);
6901 -- when Id : others =>
6902 -- if not Raised then
6904 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6909 -- [Deep_]Adjust (V.Comp_N);
6911 -- when Id : others =>
6912 -- if not Raised then
6914 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6919 -- Deep_Adjust (V._parent, False); -- If applicable
6921 -- when Id : others =>
6922 -- if not Raised then
6924 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6930 -- Adjust (V); -- If applicable
6933 -- if not Raised then
6935 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6940 -- if Raised and then not Abort then
6941 -- Raise_From_Controlled_Operation (E);
6945 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6946 -- Build the statements necessary to finalize a record type. The type
6947 -- may have discriminants and contain variant parts. Generate:
6950 -- Abort : constant Boolean := Triggered_By_Abort;
6952 -- Abort : constant Boolean := False; -- no abort
6953 -- E : Exception_Occurrence;
6954 -- Raised : Boolean := False;
6959 -- Finalize (V); -- If applicable
6962 -- if not Raised then
6964 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6969 -- case Variant_1 is
6971 -- case State_Counter_N => -- If Is_Local is enabled
6981 -- <<LN>> -- If Is_Local is enabled
6983 -- [Deep_]Finalize (V.Comp_N);
6986 -- if not Raised then
6988 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6994 -- [Deep_]Finalize (V.Comp_1);
6997 -- if not Raised then
6999 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7005 -- case State_Counter_1 => -- If Is_Local is enabled
7011 -- Deep_Finalize (V._parent, False); -- If applicable
7013 -- when Id : others =>
7014 -- if not Raised then
7016 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7020 -- if Raised and then not Abort then
7021 -- Raise_From_Controlled_Operation (E);
7025 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
7026 -- Given a derived tagged type Typ, traverse all components, find field
7027 -- _parent and return its type.
7029 procedure Preprocess_Components
7031 Num_Comps
: out Nat
;
7032 Has_POC
: out Boolean);
7033 -- Examine all components in component list Comps, count all controlled
7034 -- components and determine whether at least one of them is per-object
7035 -- constrained. Component _parent is always skipped.
7037 -----------------------------
7038 -- Build_Adjust_Statements --
7039 -----------------------------
7041 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
7042 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7043 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7045 Finalizer_Data
: Finalization_Exception_Data
;
7047 function Process_Component_List_For_Adjust
7048 (Comps
: Node_Id
) return List_Id
;
7049 -- Build all necessary adjust statements for a single component list
7051 ---------------------------------------
7052 -- Process_Component_List_For_Adjust --
7053 ---------------------------------------
7055 function Process_Component_List_For_Adjust
7056 (Comps
: Node_Id
) return List_Id
7058 Stmts
: constant List_Id
:= New_List
;
7060 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
7061 -- Process the declaration of a single controlled component
7063 ----------------------------------
7064 -- Process_Component_For_Adjust --
7065 ----------------------------------
7067 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
7068 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7069 Typ
: constant Entity_Id
:= Etype
(Id
);
7075 -- [Deep_]Adjust (V.Id);
7079 -- if not Raised then
7081 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7088 Make_Selected_Component
(Loc
,
7089 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7090 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7093 -- Guard against a missing [Deep_]Adjust when the component
7094 -- type was not properly frozen.
7096 if Present
(Adj_Call
) then
7097 if Exceptions_OK
then
7099 Make_Block_Statement
(Loc
,
7100 Handled_Statement_Sequence
=>
7101 Make_Handled_Sequence_Of_Statements
(Loc
,
7102 Statements
=> New_List
(Adj_Call
),
7103 Exception_Handlers
=> New_List
(
7104 Build_Exception_Handler
(Finalizer_Data
))));
7107 Append_To
(Stmts
, Adj_Call
);
7109 end Process_Component_For_Adjust
;
7114 Decl_Id
: Entity_Id
;
7115 Decl_Typ
: Entity_Id
;
7120 -- Start of processing for Process_Component_List_For_Adjust
7123 -- Perform an initial check, determine the number of controlled
7124 -- components in the current list and whether at least one of them
7125 -- is per-object constrained.
7127 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7129 -- The processing in this routine is done in the following order:
7130 -- 1) Regular components
7131 -- 2) Per-object constrained components
7134 if Num_Comps
> 0 then
7136 -- Process all regular components in order of declarations
7138 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7139 while Present
(Decl
) loop
7140 Decl_Id
:= Defining_Identifier
(Decl
);
7141 Decl_Typ
:= Etype
(Decl_Id
);
7143 -- Skip _parent as well as per-object constrained components
7145 if Chars
(Decl_Id
) /= Name_uParent
7146 and then Needs_Finalization
(Decl_Typ
)
7148 if Has_Access_Constraint
(Decl_Id
)
7149 and then No
(Expression
(Decl
))
7153 Process_Component_For_Adjust
(Decl
);
7157 Next_Non_Pragma
(Decl
);
7160 -- Process all per-object constrained components in order of
7164 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7165 while Present
(Decl
) loop
7166 Decl_Id
:= Defining_Identifier
(Decl
);
7167 Decl_Typ
:= Etype
(Decl_Id
);
7171 if Chars
(Decl_Id
) /= Name_uParent
7172 and then Needs_Finalization
(Decl_Typ
)
7173 and then Has_Access_Constraint
(Decl_Id
)
7174 and then No
(Expression
(Decl
))
7176 Process_Component_For_Adjust
(Decl
);
7179 Next_Non_Pragma
(Decl
);
7184 -- Process all variants, if any
7187 if Present
(Variant_Part
(Comps
)) then
7189 Var_Alts
: constant List_Id
:= New_List
;
7193 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7194 while Present
(Var
) loop
7197 -- when <discrete choices> =>
7198 -- <adjust statements>
7200 Append_To
(Var_Alts
,
7201 Make_Case_Statement_Alternative
(Loc
,
7203 New_Copy_List
(Discrete_Choices
(Var
)),
7205 Process_Component_List_For_Adjust
(
7206 Component_List
(Var
))));
7208 Next_Non_Pragma
(Var
);
7212 -- case V.<discriminant> is
7213 -- when <discrete choices 1> =>
7214 -- <adjust statements 1>
7216 -- when <discrete choices N> =>
7217 -- <adjust statements N>
7221 Make_Case_Statement
(Loc
,
7223 Make_Selected_Component
(Loc
,
7224 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7226 Make_Identifier
(Loc
,
7227 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7228 Alternatives
=> Var_Alts
);
7232 -- Add the variant case statement to the list of statements
7234 if Present
(Var_Case
) then
7235 Append_To
(Stmts
, Var_Case
);
7238 -- If the component list did not have any controlled components
7239 -- nor variants, return null.
7241 if Is_Empty_List
(Stmts
) then
7242 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
7246 end Process_Component_List_For_Adjust
;
7250 Bod_Stmts
: List_Id
:= No_List
;
7251 Finalizer_Decls
: List_Id
:= No_List
;
7254 -- Start of processing for Build_Adjust_Statements
7257 Finalizer_Decls
:= New_List
;
7258 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7260 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7261 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7266 -- Create an adjust sequence for all record components
7268 if Present
(Component_List
(Rec_Def
)) then
7270 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7273 -- A derived record type must adjust all inherited components. This
7274 -- action poses the following problem:
7276 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7281 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7283 -- Deep_Adjust (Obj._parent);
7288 -- Adjusting the derived type will invoke Adjust of the parent and
7289 -- then that of the derived type. This is undesirable because both
7290 -- routines may modify shared components. Only the Adjust of the
7291 -- derived type should be invoked.
7293 -- To prevent this double adjustment of shared components,
7294 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7296 -- procedure Deep_Adjust
7297 -- (Obj : in out Some_Type;
7298 -- Flag : Boolean := True)
7306 -- When Deep_Adjust is invoked for field _parent, a value of False is
7307 -- provided for the flag:
7309 -- Deep_Adjust (Obj._parent, False);
7311 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7313 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7318 if Needs_Finalization
(Par_Typ
) then
7322 Make_Selected_Component
(Loc
,
7323 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7325 Make_Identifier
(Loc
, Name_uParent
)),
7331 -- Deep_Adjust (V._parent, False);
7334 -- when Id : others =>
7335 -- if not Raised then
7337 -- Save_Occurrence (E,
7338 -- Get_Current_Excep.all.all);
7342 if Present
(Call
) then
7345 if Exceptions_OK
then
7347 Make_Block_Statement
(Loc
,
7348 Handled_Statement_Sequence
=>
7349 Make_Handled_Sequence_Of_Statements
(Loc
,
7350 Statements
=> New_List
(Adj_Stmt
),
7351 Exception_Handlers
=> New_List
(
7352 Build_Exception_Handler
(Finalizer_Data
))));
7355 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7361 -- Adjust the object. This action must be performed last after all
7362 -- components have been adjusted.
7364 if Is_Controlled
(Typ
) then
7370 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7379 -- if not Raised then
7381 -- Save_Occurrence (E,
7382 -- Get_Current_Excep.all.all);
7387 if Present
(Proc
) then
7389 Make_Procedure_Call_Statement
(Loc
,
7390 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7391 Parameter_Associations
=> New_List
(
7392 Make_Identifier
(Loc
, Name_V
)));
7394 if Exceptions_OK
then
7396 Make_Block_Statement
(Loc
,
7397 Handled_Statement_Sequence
=>
7398 Make_Handled_Sequence_Of_Statements
(Loc
,
7399 Statements
=> New_List
(Adj_Stmt
),
7400 Exception_Handlers
=> New_List
(
7401 Build_Exception_Handler
7402 (Finalizer_Data
))));
7405 Append_To
(Bod_Stmts
,
7406 Make_If_Statement
(Loc
,
7407 Condition
=> Make_Identifier
(Loc
, Name_F
),
7408 Then_Statements
=> New_List
(Adj_Stmt
)));
7413 -- At this point either all adjustment statements have been generated
7414 -- or the type is not controlled.
7416 if Is_Empty_List
(Bod_Stmts
) then
7417 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7423 -- Abort : constant Boolean := Triggered_By_Abort;
7425 -- Abort : constant Boolean := False; -- no abort
7427 -- E : Exception_Occurrence;
7428 -- Raised : Boolean := False;
7431 -- <adjust statements>
7433 -- if Raised and then not Abort then
7434 -- Raise_From_Controlled_Operation (E);
7439 if Exceptions_OK
then
7440 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7445 Make_Block_Statement
(Loc
,
7448 Handled_Statement_Sequence
=>
7449 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7451 end Build_Adjust_Statements
;
7453 -------------------------------
7454 -- Build_Finalize_Statements --
7455 -------------------------------
7457 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7458 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7459 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7462 Finalizer_Data
: Finalization_Exception_Data
;
7463 Last_POC_Call
: Node_Id
:= Empty
;
7465 function Process_Component_List_For_Finalize
7467 In_Variant_Part
: Boolean := False) return List_Id
;
7468 -- Build all necessary finalization statements for a single component
7469 -- list. The statements may include a jump circuitry if flag Is_Local
7470 -- is enabled. In_Variant_Part indicates whether this is a recursive
7473 -----------------------------------------
7474 -- Process_Component_List_For_Finalize --
7475 -----------------------------------------
7477 function Process_Component_List_For_Finalize
7479 In_Variant_Part
: Boolean := False) return List_Id
7481 procedure Process_Component_For_Finalize
7486 Num_Comps
: in out Nat
);
7487 -- Process the declaration of a single controlled component. If
7488 -- flag Is_Local is enabled, create the corresponding label and
7489 -- jump circuitry. Alts is the list of case alternatives, Decls
7490 -- is the top level declaration list where labels are declared
7491 -- and Stmts is the list of finalization actions. Num_Comps
7492 -- denotes the current number of components needing finalization.
7494 ------------------------------------
7495 -- Process_Component_For_Finalize --
7496 ------------------------------------
7498 procedure Process_Component_For_Finalize
7503 Num_Comps
: in out Nat
)
7505 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7506 Typ
: constant Entity_Id
:= Etype
(Id
);
7513 Label_Id
: Entity_Id
;
7520 Make_Identifier
(Loc
,
7521 Chars
=> New_External_Name
('L', Num_Comps
));
7522 Set_Entity
(Label_Id
,
7523 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7524 Label
:= Make_Label
(Loc
, Label_Id
);
7527 Make_Implicit_Label_Declaration
(Loc
,
7528 Defining_Identifier
=> Entity
(Label_Id
),
7529 Label_Construct
=> Label
));
7536 Make_Case_Statement_Alternative
(Loc
,
7537 Discrete_Choices
=> New_List
(
7538 Make_Integer_Literal
(Loc
, Num_Comps
)),
7540 Statements
=> New_List
(
7541 Make_Goto_Statement
(Loc
,
7543 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7548 Append_To
(Stmts
, Label
);
7550 -- Decrease the number of components to be processed.
7551 -- This action yields a new Label_Id in future calls.
7553 Num_Comps
:= Num_Comps
- 1;
7558 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7560 -- begin -- Exception handlers allowed
7561 -- [Deep_]Finalize (V.Id);
7564 -- if not Raised then
7566 -- Save_Occurrence (E,
7567 -- Get_Current_Excep.all.all);
7574 Make_Selected_Component
(Loc
,
7575 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7576 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7579 -- Guard against a missing [Deep_]Finalize when the component
7580 -- type was not properly frozen.
7582 if Present
(Fin_Call
) then
7583 if Exceptions_OK
then
7585 Make_Block_Statement
(Loc
,
7586 Handled_Statement_Sequence
=>
7587 Make_Handled_Sequence_Of_Statements
(Loc
,
7588 Statements
=> New_List
(Fin_Call
),
7589 Exception_Handlers
=> New_List
(
7590 Build_Exception_Handler
(Finalizer_Data
))));
7593 Append_To
(Stmts
, Fin_Call
);
7595 end Process_Component_For_Finalize
;
7600 Counter_Id
: Entity_Id
:= Empty
;
7602 Decl_Id
: Entity_Id
;
7603 Decl_Typ
: Entity_Id
;
7606 Jump_Block
: Node_Id
;
7608 Label_Id
: Entity_Id
;
7613 -- Start of processing for Process_Component_List_For_Finalize
7616 -- Perform an initial check, look for controlled and per-object
7617 -- constrained components.
7619 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7621 -- Create a state counter to service the current component list.
7622 -- This step is performed before the variants are inspected in
7623 -- order to generate the same state counter names as those from
7624 -- Build_Initialize_Statements.
7626 if Num_Comps
> 0 and then Is_Local
then
7627 Counter
:= Counter
+ 1;
7630 Make_Defining_Identifier
(Loc
,
7631 Chars
=> New_External_Name
('C', Counter
));
7634 -- Process the component in the following order:
7636 -- 2) Per-object constrained components
7637 -- 3) Regular components
7639 -- Start with the variant parts
7642 if Present
(Variant_Part
(Comps
)) then
7644 Var_Alts
: constant List_Id
:= New_List
;
7648 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7649 while Present
(Var
) loop
7652 -- when <discrete choices> =>
7653 -- <finalize statements>
7655 Append_To
(Var_Alts
,
7656 Make_Case_Statement_Alternative
(Loc
,
7658 New_Copy_List
(Discrete_Choices
(Var
)),
7660 Process_Component_List_For_Finalize
(
7661 Component_List
(Var
),
7662 In_Variant_Part
=> True)));
7664 Next_Non_Pragma
(Var
);
7668 -- case V.<discriminant> is
7669 -- when <discrete choices 1> =>
7670 -- <finalize statements 1>
7672 -- when <discrete choices N> =>
7673 -- <finalize statements N>
7677 Make_Case_Statement
(Loc
,
7679 Make_Selected_Component
(Loc
,
7680 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7682 Make_Identifier
(Loc
,
7683 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7684 Alternatives
=> Var_Alts
);
7688 -- The current component list does not have a single controlled
7689 -- component, however it may contain variants. Return the case
7690 -- statement for the variants or nothing.
7692 if Num_Comps
= 0 then
7693 if Present
(Var_Case
) then
7694 return New_List
(Var_Case
);
7696 return New_List
(Make_Null_Statement
(Loc
));
7700 -- Prepare all lists
7706 -- Process all per-object constrained components in reverse order
7709 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7710 while Present
(Decl
) loop
7711 Decl_Id
:= Defining_Identifier
(Decl
);
7712 Decl_Typ
:= Etype
(Decl_Id
);
7716 if Chars
(Decl_Id
) /= Name_uParent
7717 and then Needs_Finalization
(Decl_Typ
)
7718 and then Has_Access_Constraint
(Decl_Id
)
7719 and then No
(Expression
(Decl
))
7721 Process_Component_For_Finalize
7722 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7725 Prev_Non_Pragma
(Decl
);
7729 if not In_Variant_Part
then
7730 Last_POC_Call
:= Last
(Stmts
);
7731 -- In the case of a type extension, the deep-finalize call
7732 -- for the _Parent component will be inserted here.
7735 -- Process the rest of the components in reverse order
7737 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7738 while Present
(Decl
) loop
7739 Decl_Id
:= Defining_Identifier
(Decl
);
7740 Decl_Typ
:= Etype
(Decl_Id
);
7744 if Chars
(Decl_Id
) /= Name_uParent
7745 and then Needs_Finalization
(Decl_Typ
)
7747 -- Skip per-object constrained components since they were
7748 -- handled in the above step.
7750 if Has_Access_Constraint
(Decl_Id
)
7751 and then No
(Expression
(Decl
))
7755 Process_Component_For_Finalize
7756 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7760 Prev_Non_Pragma
(Decl
);
7765 -- LN : label; -- If Is_Local is enabled
7770 -- case CounterX is .
7780 -- <<LN>> -- If Is_Local is enabled
7782 -- [Deep_]Finalize (V.CompY);
7784 -- when Id : others =>
7785 -- if not Raised then
7787 -- Save_Occurrence (E,
7788 -- Get_Current_Excep.all.all);
7792 -- <<L0>> -- If Is_Local is enabled
7797 -- Add the declaration of default jump location L0, its
7798 -- corresponding alternative and its place in the statements.
7800 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7801 Set_Entity
(Label_Id
,
7802 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7803 Label
:= Make_Label
(Loc
, Label_Id
);
7805 Append_To
(Decls
, -- declaration
7806 Make_Implicit_Label_Declaration
(Loc
,
7807 Defining_Identifier
=> Entity
(Label_Id
),
7808 Label_Construct
=> Label
));
7810 Append_To
(Alts
, -- alternative
7811 Make_Case_Statement_Alternative
(Loc
,
7812 Discrete_Choices
=> New_List
(
7813 Make_Others_Choice
(Loc
)),
7815 Statements
=> New_List
(
7816 Make_Goto_Statement
(Loc
,
7817 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7819 Append_To
(Stmts
, Label
); -- statement
7821 -- Create the jump block
7824 Make_Case_Statement
(Loc
,
7825 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7826 Alternatives
=> Alts
));
7830 Make_Block_Statement
(Loc
,
7831 Declarations
=> Decls
,
7832 Handled_Statement_Sequence
=>
7833 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7835 if Present
(Var_Case
) then
7836 return New_List
(Var_Case
, Jump_Block
);
7838 return New_List
(Jump_Block
);
7840 end Process_Component_List_For_Finalize
;
7844 Bod_Stmts
: List_Id
:= No_List
;
7845 Finalizer_Decls
: List_Id
:= No_List
;
7848 -- Start of processing for Build_Finalize_Statements
7851 Finalizer_Decls
:= New_List
;
7852 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7854 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7855 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7860 -- Create a finalization sequence for all record components
7862 if Present
(Component_List
(Rec_Def
)) then
7864 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7867 -- A derived record type must finalize all inherited components. This
7868 -- action poses the following problem:
7870 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7875 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7877 -- Deep_Finalize (Obj._parent);
7882 -- Finalizing the derived type will invoke Finalize of the parent and
7883 -- then that of the derived type. This is undesirable because both
7884 -- routines may modify shared components. Only the Finalize of the
7885 -- derived type should be invoked.
7887 -- To prevent this double adjustment of shared components,
7888 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7890 -- procedure Deep_Finalize
7891 -- (Obj : in out Some_Type;
7892 -- Flag : Boolean := True)
7900 -- When Deep_Finalize is invoked for field _parent, a value of False
7901 -- is provided for the flag:
7903 -- Deep_Finalize (Obj._parent, False);
7905 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7907 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7912 if Needs_Finalization
(Par_Typ
) then
7916 Make_Selected_Component
(Loc
,
7917 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7919 Make_Identifier
(Loc
, Name_uParent
)),
7925 -- Deep_Finalize (V._parent, False);
7928 -- when Id : others =>
7929 -- if not Raised then
7931 -- Save_Occurrence (E,
7932 -- Get_Current_Excep.all.all);
7936 if Present
(Call
) then
7939 if Exceptions_OK
then
7941 Make_Block_Statement
(Loc
,
7942 Handled_Statement_Sequence
=>
7943 Make_Handled_Sequence_Of_Statements
(Loc
,
7944 Statements
=> New_List
(Fin_Stmt
),
7945 Exception_Handlers
=> New_List
(
7946 Build_Exception_Handler
7947 (Finalizer_Data
))));
7950 -- The intended component finalization order is
7951 -- 1) POC components of extension
7952 -- 2) _Parent component
7953 -- 3) non-POC components of extension.
7955 -- With this "finalize the parent part in the middle"
7956 -- ordering, we can avoid the need for making two
7957 -- calls to the parent's subprogram in the way that
7958 -- is necessary for Init_Procs. This does have the
7959 -- peculiar (but legal) consequence that the parent's
7960 -- non-POC components are finalized before the
7961 -- non-POC extension components. This violates the
7962 -- usual "finalize in reverse declaration order"
7963 -- principle, but that's ok (see Ada RM 7.6.1(9)).
7965 -- Last_POC_Call should be non-empty if the extension
7966 -- has at least one POC. Interactions with variant
7967 -- parts are incorrectly ignored.
7969 if Present
(Last_POC_Call
) then
7970 Insert_After
(Last_POC_Call
, Fin_Stmt
);
7972 -- At this point, we could look for the common case
7973 -- where there are no POC components anywhere in
7974 -- sight (inherited or not) and, in that common case,
7975 -- call Append_To instead of Prepend_To. That would
7976 -- result in finalizing the parent part after, rather
7977 -- than before, the extension components. That might
7978 -- be more intuitive (as discussed in preceding
7979 -- comment), but it is not required.
7980 Prepend_To
(Bod_Stmts
, Fin_Stmt
);
7987 -- Finalize the object. This action must be performed first before
7988 -- all components have been finalized.
7990 if Is_Controlled
(Typ
) and then not Is_Local
then
7996 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
8005 -- if not Raised then
8007 -- Save_Occurrence (E,
8008 -- Get_Current_Excep.all.all);
8013 if Present
(Proc
) then
8015 Make_Procedure_Call_Statement
(Loc
,
8016 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8017 Parameter_Associations
=> New_List
(
8018 Make_Identifier
(Loc
, Name_V
)));
8020 if Exceptions_OK
then
8022 Make_Block_Statement
(Loc
,
8023 Handled_Statement_Sequence
=>
8024 Make_Handled_Sequence_Of_Statements
(Loc
,
8025 Statements
=> New_List
(Fin_Stmt
),
8026 Exception_Handlers
=> New_List
(
8027 Build_Exception_Handler
8028 (Finalizer_Data
))));
8031 Prepend_To
(Bod_Stmts
,
8032 Make_If_Statement
(Loc
,
8033 Condition
=> Make_Identifier
(Loc
, Name_F
),
8034 Then_Statements
=> New_List
(Fin_Stmt
)));
8039 -- At this point either all finalization statements have been
8040 -- generated or the type is not controlled.
8042 if No
(Bod_Stmts
) then
8043 return New_List
(Make_Null_Statement
(Loc
));
8047 -- Abort : constant Boolean := Triggered_By_Abort;
8049 -- Abort : constant Boolean := False; -- no abort
8051 -- E : Exception_Occurrence;
8052 -- Raised : Boolean := False;
8055 -- <finalize statements>
8057 -- if Raised and then not Abort then
8058 -- Raise_From_Controlled_Operation (E);
8063 if Exceptions_OK
then
8064 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
8069 Make_Block_Statement
(Loc
,
8072 Handled_Statement_Sequence
=>
8073 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
8075 end Build_Finalize_Statements
;
8077 -----------------------
8078 -- Parent_Field_Type --
8079 -----------------------
8081 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
8085 Field
:= First_Entity
(Typ
);
8086 while Present
(Field
) loop
8087 if Chars
(Field
) = Name_uParent
then
8088 return Etype
(Field
);
8091 Next_Entity
(Field
);
8094 -- A derived tagged type should always have a parent field
8096 raise Program_Error
;
8097 end Parent_Field_Type
;
8099 ---------------------------
8100 -- Preprocess_Components --
8101 ---------------------------
8103 procedure Preprocess_Components
8105 Num_Comps
: out Nat
;
8106 Has_POC
: out Boolean)
8116 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
8117 while Present
(Decl
) loop
8118 Id
:= Defining_Identifier
(Decl
);
8121 -- Skip field _parent
8123 if Chars
(Id
) /= Name_uParent
8124 and then Needs_Finalization
(Typ
)
8126 Num_Comps
:= Num_Comps
+ 1;
8128 if Has_Access_Constraint
(Id
)
8129 and then No
(Expression
(Decl
))
8135 Next_Non_Pragma
(Decl
);
8137 end Preprocess_Components
;
8139 -- Start of processing for Make_Deep_Record_Body
8143 when Address_Case
=>
8144 return Make_Finalize_Address_Stmts
(Typ
);
8147 return Build_Adjust_Statements
(Typ
);
8149 when Finalize_Case
=>
8150 return Build_Finalize_Statements
(Typ
);
8152 when Initialize_Case
=>
8154 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8157 if Is_Controlled
(Typ
) then
8159 Make_Procedure_Call_Statement
(Loc
,
8162 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
8163 Parameter_Associations
=> New_List
(
8164 Make_Identifier
(Loc
, Name_V
))));
8170 end Make_Deep_Record_Body
;
8172 ----------------------
8173 -- Make_Final_Call --
8174 ----------------------
8176 function Make_Final_Call
8179 Skip_Self
: Boolean := False) return Node_Id
8181 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8183 Prot_Typ
: Entity_Id
:= Empty
;
8184 Fin_Id
: Entity_Id
:= Empty
;
8191 -- Recover the proper type which contains [Deep_]Finalize
8193 if Is_Class_Wide_Type
(Typ
) then
8194 Utyp
:= Root_Type
(Typ
);
8197 elsif Is_Concurrent_Type
(Typ
) then
8198 Utyp
:= Corresponding_Record_Type
(Typ
);
8200 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8202 elsif Is_Private_Type
(Typ
)
8203 and then Present
(Underlying_Type
(Typ
))
8204 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8206 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8208 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8215 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8216 Set_Assignment_OK
(Ref
);
8218 -- Deal with untagged derivation of private views. If the parent type
8219 -- is a protected type, Deep_Finalize is found on the corresponding
8220 -- record of the ancestor.
8222 if Is_Untagged_Derivation
(Typ
) then
8223 if Is_Protected_Type
(Typ
) then
8224 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
8226 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8228 if Is_Protected_Type
(Utyp
) then
8229 Utyp
:= Corresponding_Record_Type
(Utyp
);
8233 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8234 Set_Assignment_OK
(Ref
);
8237 -- Deal with derived private types which do not inherit primitives from
8238 -- their parents. In this case, [Deep_]Finalize can be found in the full
8239 -- view of the parent type.
8242 and then Is_Tagged_Type
(Utyp
)
8243 and then Is_Derived_Type
(Utyp
)
8244 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
8245 and then Is_Private_Type
(Etype
(Utyp
))
8246 and then Present
(Full_View
(Etype
(Utyp
)))
8248 Utyp
:= Full_View
(Etype
(Utyp
));
8249 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8250 Set_Assignment_OK
(Ref
);
8253 -- When dealing with the completion of a private type, use the base type
8256 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8257 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
8259 Utyp
:= Base_Type
(Utyp
);
8260 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8261 Set_Assignment_OK
(Ref
);
8264 -- Detect if Typ is a protected type or an expanded protected type and
8265 -- store the relevant type within Prot_Typ for later processing.
8267 if Is_Protected_Type
(Typ
) then
8270 elsif Ekind
(Typ
) = E_Record_Type
8271 and then Present
(Corresponding_Concurrent_Type
(Typ
))
8272 and then Is_Protected_Type
(Corresponding_Concurrent_Type
(Typ
))
8274 Prot_Typ
:= Corresponding_Concurrent_Type
(Typ
);
8277 -- The underlying type may not be present due to a missing full view. In
8278 -- this case freezing did not take place and there is no [Deep_]Finalize
8279 -- primitive to call.
8284 elsif Skip_Self
then
8285 if Has_Controlled_Component
(Utyp
) then
8286 if Is_Tagged_Type
(Utyp
) then
8287 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8289 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8293 -- Class-wide types, interfaces and types with controlled components
8295 elsif Is_Class_Wide_Type
(Typ
)
8296 or else Is_Interface
(Typ
)
8297 or else Has_Controlled_Component
(Utyp
)
8299 if Is_Tagged_Type
(Utyp
) then
8300 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8302 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
8305 -- Derivations from [Limited_]Controlled
8307 elsif Is_Controlled
(Utyp
) then
8308 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8312 elsif Is_Tagged_Type
(Utyp
) then
8313 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8315 -- Protected types: these also require finalization even though they
8316 -- are not marked controlled explicitly.
8318 elsif Present
(Prot_Typ
) then
8319 -- Protected objects do not need to be finalized on restricted
8322 if Restricted_Profile
then
8325 -- ??? Only handle the simple case for now. Will not support a record
8326 -- or array containing protected objects.
8328 elsif Is_Simple_Protected_Type
(Prot_Typ
) then
8329 Fin_Id
:= RTE
(RE_Finalize_Protection
);
8331 raise Program_Error
;
8334 raise Program_Error
;
8337 if Present
(Fin_Id
) then
8339 -- When finalizing a class-wide object, do not convert to the root
8340 -- type in order to produce a dispatching call.
8342 if Is_Class_Wide_Type
(Typ
) then
8345 -- Ensure that a finalization routine is at least decorated in order
8346 -- to inspect the object parameter.
8348 elsif Analyzed
(Fin_Id
)
8349 or else Ekind
(Fin_Id
) = E_Procedure
8351 -- In certain cases, such as the creation of Stream_Read, the
8352 -- visible entity of the type is its full view. Since Stream_Read
8353 -- will have to create an object of type Typ, the local object
8354 -- will be finalzed by the scope finalizer generated later on. The
8355 -- object parameter of Deep_Finalize will always use the private
8356 -- view of the type. To avoid such a clash between a private and a
8357 -- full view, perform an unchecked conversion of the object
8358 -- reference to the private view.
8361 Formal_Typ
: constant Entity_Id
:=
8362 Etype
(First_Formal
(Fin_Id
));
8364 if Is_Private_Type
(Formal_Typ
)
8365 and then Present
(Full_View
(Formal_Typ
))
8366 and then Full_View
(Formal_Typ
) = Utyp
8368 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8372 -- If the object is unanalyzed, set its expected type for use in
8373 -- Convert_View in case an additional conversion is needed.
8376 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
8378 Set_Etype
(Ref
, Typ
);
8381 Ref
:= Convert_View
(Fin_Id
, Ref
);
8388 Skip_Self
=> Skip_Self
);
8390 pragma Assert
(Serious_Errors_Detected
> 0
8391 or else not Has_Controlled_Component
(Utyp
));
8394 end Make_Final_Call
;
8396 --------------------------------
8397 -- Make_Finalize_Address_Body --
8398 --------------------------------
8400 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8401 Is_Task
: constant Boolean :=
8402 Ekind
(Typ
) = E_Record_Type
8403 and then Is_Concurrent_Record_Type
(Typ
)
8404 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8406 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8407 Proc_Id
: Entity_Id
;
8411 -- The corresponding records of task types are not controlled by design.
8412 -- For the sake of completeness, create an empty Finalize_Address to be
8413 -- used in task class-wide allocations.
8418 -- Nothing to do if the type is not controlled or it already has a
8419 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8420 -- come from source. These are usually generated for completeness and
8421 -- do not need the Finalize_Address primitive.
8423 elsif not Needs_Finalization
(Typ
)
8424 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8426 (Is_Class_Wide_Type
(Typ
)
8427 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8428 and then not Comes_From_Source
(Root_Type
(Typ
)))
8433 -- Do not generate Finalize_Address routine for CodePeer
8435 if CodePeer_Mode
then
8440 Make_Defining_Identifier
(Loc
,
8441 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8445 -- procedure <Typ>FD (V : System.Address) is
8447 -- null; -- for tasks
8449 -- declare -- for all other types
8450 -- type Pnn is access all Typ;
8451 -- for Pnn'Storage_Size use 0;
8453 -- [Deep_]Finalize (Pnn (V).all);
8458 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8460 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8464 Make_Subprogram_Body
(Loc
,
8466 Make_Procedure_Specification
(Loc
,
8467 Defining_Unit_Name
=> Proc_Id
,
8469 Parameter_Specifications
=> New_List
(
8470 Make_Parameter_Specification
(Loc
,
8471 Defining_Identifier
=>
8472 Make_Defining_Identifier
(Loc
, Name_V
),
8474 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8476 Declarations
=> No_List
,
8478 Handled_Statement_Sequence
=>
8479 Make_Handled_Sequence_Of_Statements
(Loc
,
8480 Statements
=> Stmts
)));
8482 Set_TSS
(Typ
, Proc_Id
);
8483 end Make_Finalize_Address_Body
;
8485 ---------------------------------
8486 -- Make_Finalize_Address_Stmts --
8487 ---------------------------------
8489 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8490 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8493 Desig_Typ
: Entity_Id
;
8494 Fin_Block
: Node_Id
;
8497 Ptr_Typ
: Entity_Id
;
8500 if Is_Array_Type
(Typ
) then
8501 if Is_Constrained
(First_Subtype
(Typ
)) then
8502 Desig_Typ
:= First_Subtype
(Typ
);
8504 Desig_Typ
:= Base_Type
(Typ
);
8507 -- Class-wide types of constrained root types
8509 elsif Is_Class_Wide_Type
(Typ
)
8510 and then Has_Discriminants
(Root_Type
(Typ
))
8512 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8515 Parent_Typ
: Entity_Id
;
8518 -- Climb the parent type chain looking for a non-constrained type
8520 Parent_Typ
:= Root_Type
(Typ
);
8521 while Parent_Typ
/= Etype
(Parent_Typ
)
8522 and then Has_Discriminants
(Parent_Typ
)
8524 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8526 Parent_Typ
:= Etype
(Parent_Typ
);
8529 -- Handle views created for tagged types with unknown
8532 if Is_Underlying_Record_View
(Parent_Typ
) then
8533 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8536 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
8546 -- type Ptr_Typ is access all Typ;
8547 -- for Ptr_Typ'Storage_Size use 0;
8549 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8552 Make_Full_Type_Declaration
(Loc
,
8553 Defining_Identifier
=> Ptr_Typ
,
8555 Make_Access_To_Object_Definition
(Loc
,
8556 All_Present
=> True,
8557 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8559 Make_Attribute_Definition_Clause
(Loc
,
8560 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8561 Chars
=> Name_Storage_Size
,
8562 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8564 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8566 -- Unconstrained arrays require special processing in order to retrieve
8567 -- the elements. To achieve this, we have to skip the dope vector which
8568 -- lays in front of the elements and then use a thin pointer to perform
8569 -- the address-to-access conversion.
8571 if Is_Array_Type
(Typ
)
8572 and then not Is_Constrained
(First_Subtype
(Typ
))
8575 Dope_Id
: Entity_Id
;
8578 -- Ensure that Ptr_Typ is a thin pointer; generate:
8579 -- for Ptr_Typ'Size use System.Address'Size;
8582 Make_Attribute_Definition_Clause
(Loc
,
8583 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8586 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8589 -- Dnn : constant Storage_Offset :=
8590 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8592 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8595 Make_Object_Declaration
(Loc
,
8596 Defining_Identifier
=> Dope_Id
,
8597 Constant_Present
=> True,
8598 Object_Definition
=>
8599 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8601 Make_Op_Divide
(Loc
,
8603 Make_Attribute_Reference
(Loc
,
8604 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8605 Attribute_Name
=> Name_Descriptor_Size
),
8607 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8609 -- Shift the address from the start of the dope vector to the
8610 -- start of the elements:
8614 -- Note that this is done through a wrapper routine since RTSfind
8615 -- cannot retrieve operations with string names of the form "+".
8618 Make_Function_Call
(Loc
,
8620 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8621 Parameter_Associations
=> New_List
(
8623 New_Occurrence_Of
(Dope_Id
, Loc
)));
8630 Make_Explicit_Dereference
(Loc
,
8631 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8634 if Present
(Fin_Call
) then
8636 Make_Block_Statement
(Loc
,
8637 Declarations
=> Decls
,
8638 Handled_Statement_Sequence
=>
8639 Make_Handled_Sequence_Of_Statements
(Loc
,
8640 Statements
=> New_List
(Fin_Call
)));
8642 -- Otherwise previous errors or a missing full view may prevent the
8643 -- proper freezing of the designated type. If this is the case, there
8644 -- is no [Deep_]Finalize primitive to call.
8647 Fin_Block
:= Make_Null_Statement
(Loc
);
8650 return New_List
(Fin_Block
);
8651 end Make_Finalize_Address_Stmts
;
8653 -------------------------------------
8654 -- Make_Handler_For_Ctrl_Operation --
8655 -------------------------------------
8659 -- when E : others =>
8660 -- Raise_From_Controlled_Operation (E);
8665 -- raise Program_Error [finalize raised exception];
8667 -- depending on whether Raise_From_Controlled_Operation is available
8669 function Make_Handler_For_Ctrl_Operation
8670 (Loc
: Source_Ptr
) return Node_Id
8673 -- Choice parameter (for the first case above)
8675 Raise_Node
: Node_Id
;
8676 -- Procedure call or raise statement
8679 -- Standard run-time: add choice parameter E and pass it to
8680 -- Raise_From_Controlled_Operation so that the original exception
8681 -- name and message can be recorded in the exception message for
8684 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8685 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8687 Make_Procedure_Call_Statement
(Loc
,
8690 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8691 Parameter_Associations
=> New_List
(
8692 New_Occurrence_Of
(E_Occ
, Loc
)));
8694 -- Restricted run-time: exception messages are not supported
8699 Make_Raise_Program_Error
(Loc
,
8700 Reason
=> PE_Finalize_Raised_Exception
);
8704 Make_Implicit_Exception_Handler
(Loc
,
8705 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8706 Choice_Parameter
=> E_Occ
,
8707 Statements
=> New_List
(Raise_Node
));
8708 end Make_Handler_For_Ctrl_Operation
;
8710 --------------------
8711 -- Make_Init_Call --
8712 --------------------
8714 function Make_Init_Call
8716 Typ
: Entity_Id
) return Node_Id
8718 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8727 -- Deal with the type and object reference. Depending on the context, an
8728 -- object reference may need several conversions.
8730 if Is_Concurrent_Type
(Typ
) then
8732 Utyp
:= Corresponding_Record_Type
(Typ
);
8733 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8735 elsif Is_Private_Type
(Typ
)
8736 and then Present
(Full_View
(Typ
))
8737 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8740 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8741 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8748 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8749 Set_Assignment_OK
(Ref
);
8751 -- Deal with untagged derivation of private views
8753 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8754 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8755 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8757 -- The following is to prevent problems with UC see 1.156 RH ???
8759 Set_Assignment_OK
(Ref
);
8762 -- If the underlying_type is a subtype, then we are dealing with the
8763 -- completion of a private type. We need to access the base type and
8764 -- generate a conversion to it.
8766 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8767 pragma Assert
(Is_Private_Type
(Typ
));
8768 Utyp
:= Base_Type
(Utyp
);
8769 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8772 -- The underlying type may not be present due to a missing full view.
8773 -- In this case freezing did not take place and there is no suitable
8774 -- [Deep_]Initialize primitive to call.
8775 -- If Typ is protected then no additional processing is needed either.
8778 or else Is_Protected_Type
(Typ
)
8783 -- Select the appropriate version of initialize
8785 if Has_Controlled_Component
(Utyp
) then
8786 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8788 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8789 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8792 -- If initialization procedure for an array of controlled objects is
8793 -- trivial, do not generate a useless call to it.
8794 -- The initialization procedure may be missing altogether in the case
8795 -- of a derived container whose components have trivial initialization.
8798 or else (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8800 (not Comes_From_Source
(Proc
)
8801 and then Present
(Alias
(Proc
))
8802 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8807 -- The object reference may need another conversion depending on the
8808 -- type of the formal and that of the actual.
8810 Ref
:= Convert_View
(Proc
, Ref
);
8813 -- [Deep_]Initialize (Ref);
8816 Make_Procedure_Call_Statement
(Loc
,
8817 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8818 Parameter_Associations
=> New_List
(Ref
));
8821 ------------------------------
8822 -- Make_Local_Deep_Finalize --
8823 ------------------------------
8825 function Make_Local_Deep_Finalize
8827 Nam
: Entity_Id
) return Node_Id
8829 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8833 Formals
:= New_List
(
8837 Make_Parameter_Specification
(Loc
,
8838 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8840 Out_Present
=> True,
8841 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8843 -- F : Boolean := True
8845 Make_Parameter_Specification
(Loc
,
8846 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8847 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8848 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8850 -- Add the necessary number of counters to represent the initialization
8851 -- state of an object.
8854 Make_Subprogram_Body
(Loc
,
8856 Make_Procedure_Specification
(Loc
,
8857 Defining_Unit_Name
=> Nam
,
8858 Parameter_Specifications
=> Formals
),
8860 Declarations
=> No_List
,
8862 Handled_Statement_Sequence
=>
8863 Make_Handled_Sequence_Of_Statements
(Loc
,
8864 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8865 end Make_Local_Deep_Finalize
;
8867 ------------------------------------
8868 -- Make_Set_Finalize_Address_Call --
8869 ------------------------------------
8871 function Make_Set_Finalize_Address_Call
8873 Ptr_Typ
: Entity_Id
) return Node_Id
8875 -- It is possible for Ptr_Typ to be a partial view, if the access type
8876 -- is a full view declared in the private part of a nested package, and
8877 -- the finalization actions take place when completing analysis of the
8878 -- enclosing unit. For this reason use Underlying_Type twice below.
8880 Desig_Typ
: constant Entity_Id
:=
8882 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8883 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8884 Fin_Mas
: constant Entity_Id
:=
8885 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8888 -- Both the finalization master and primitive Finalize_Address must be
8891 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8894 -- Set_Finalize_Address
8895 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8898 Make_Procedure_Call_Statement
(Loc
,
8900 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8901 Parameter_Associations
=> New_List
(
8902 New_Occurrence_Of
(Fin_Mas
, Loc
),
8904 Make_Attribute_Reference
(Loc
,
8905 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8906 Attribute_Name
=> Name_Unrestricted_Access
)));
8907 end Make_Set_Finalize_Address_Call
;
8909 --------------------------
8910 -- Make_Transient_Block --
8911 --------------------------
8913 function Make_Transient_Block
8916 Par
: Node_Id
) return Node_Id
8918 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8919 -- Determine whether scoping entity Id manages the secondary stack
8921 function Within_Loop_Statement
(N
: Node_Id
) return Boolean;
8922 -- Return True when N appears within a loop and no block is containing N
8924 -----------------------
8925 -- Manages_Sec_Stack --
8926 -----------------------
8928 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8932 -- An exception handler with a choice parameter utilizes a dummy
8933 -- block to provide a declarative region. Such a block should not
8934 -- be considered because it never manifests in the tree and can
8935 -- never release the secondary stack.
8939 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8946 return Uses_Sec_Stack
(Id
);
8951 end Manages_Sec_Stack
;
8953 ---------------------------
8954 -- Within_Loop_Statement --
8955 ---------------------------
8957 function Within_Loop_Statement
(N
: Node_Id
) return Boolean is
8958 Par
: Node_Id
:= Parent
(N
);
8961 while Nkind
(Par
) not in
8962 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
8963 N_Package_Specification | N_Proper_Body
8965 pragma Assert
(Present
(Par
));
8966 Par
:= Parent
(Par
);
8969 return Nkind
(Par
) = N_Loop_Statement
;
8970 end Within_Loop_Statement
;
8974 Decls
: constant List_Id
:= New_List
;
8975 Instrs
: constant List_Id
:= New_List
(Action
);
8976 Trans_Id
: constant Entity_Id
:= Current_Scope
;
8982 -- Start of processing for Make_Transient_Block
8985 -- Even though the transient block is tasked with managing the secondary
8986 -- stack, the block may forgo this functionality depending on how the
8987 -- secondary stack is managed by enclosing scopes.
8989 if Manages_Sec_Stack
(Trans_Id
) then
8991 -- Determine whether an enclosing scope already manages the secondary
8994 Scop
:= Scope
(Trans_Id
);
8995 while Present
(Scop
) loop
8997 -- It should not be possible to reach Standard without hitting one
8998 -- of the other cases first unless Standard was manually pushed.
9000 if Scop
= Standard_Standard
then
9003 -- The transient block is within a function which returns on the
9004 -- secondary stack. Take a conservative approach and assume that
9005 -- the value on the secondary stack is part of the result. Note
9006 -- that it is not possible to detect this dependency without flow
9007 -- analysis which the compiler does not have. Letting the object
9008 -- live longer than the transient block will not leak any memory
9009 -- because the caller will reclaim the total storage used by the
9012 elsif Ekind
(Scop
) = E_Function
9013 and then Sec_Stack_Needed_For_Return
(Scop
)
9015 Set_Uses_Sec_Stack
(Trans_Id
, False);
9018 -- The transient block must manage the secondary stack when the
9019 -- block appears within a loop in order to reclaim the memory at
9022 elsif Ekind
(Scop
) = E_Loop
then
9025 -- Ditto when the block appears without a block that does not
9026 -- manage the secondary stack and is located within a loop.
9028 elsif Ekind
(Scop
) = E_Block
9029 and then not Manages_Sec_Stack
(Scop
)
9030 and then Present
(Block_Node
(Scop
))
9031 and then Within_Loop_Statement
(Block_Node
(Scop
))
9035 -- The transient block does not need to manage the secondary stack
9036 -- when there is an enclosing construct which already does that.
9037 -- This optimization saves on SS_Mark and SS_Release calls but may
9038 -- allow objects to live a little longer than required.
9040 -- The transient block must manage the secondary stack when switch
9041 -- -gnatd.s (strict management) is in effect.
9043 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
9044 Set_Uses_Sec_Stack
(Trans_Id
, False);
9047 -- Prevent the search from going too far because transient blocks
9048 -- are bounded by packages and subprogram scopes.
9050 elsif Ekind
(Scop
) in E_Entry
9060 Scop
:= Scope
(Scop
);
9064 -- Create the transient block. Set the parent now since the block itself
9065 -- is not part of the tree. The current scope is the E_Block entity that
9066 -- has been pushed by Establish_Transient_Scope.
9068 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
9071 Make_Block_Statement
(Loc
,
9072 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
9073 Declarations
=> Decls
,
9074 Handled_Statement_Sequence
=>
9075 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
9076 Has_Created_Identifier
=> True);
9077 Set_Parent
(Block
, Par
);
9079 -- Insert actions stuck in the transient scopes as well as all freezing
9080 -- nodes needed by those actions. Do not insert cleanup actions here,
9081 -- they will be transferred to the newly created block.
9083 Insert_Actions_In_Scope_Around
9084 (Action
, Clean
=> False, Manage_SS
=> False);
9086 Insert
:= Prev
(Action
);
9088 if Present
(Insert
) then
9089 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
9092 -- Transfer cleanup actions to the newly created block
9095 Cleanup_Actions
: List_Id
9096 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
9097 Actions_To_Be_Wrapped
(Cleanup
);
9099 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
9100 Cleanup_Actions
:= No_List
;
9103 -- When the transient scope was established, we pushed the entry for the
9104 -- transient scope onto the scope stack, so that the scope was active
9105 -- for the installation of finalizable entities etc. Now we must remove
9106 -- this entry, since we have constructed a proper block.
9111 end Make_Transient_Block
;
9113 ------------------------
9114 -- Node_To_Be_Wrapped --
9115 ------------------------
9117 function Node_To_Be_Wrapped
return Node_Id
is
9119 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
9120 end Node_To_Be_Wrapped
;
9122 ----------------------------
9123 -- Store_Actions_In_Scope --
9124 ----------------------------
9126 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
9127 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
9128 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
9131 if Is_Empty_List
(Actions
) then
9134 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
9135 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
9137 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
9142 elsif AK
= Before
then
9143 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
9146 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
9148 end Store_Actions_In_Scope
;
9150 ----------------------------------
9151 -- Store_After_Actions_In_Scope --
9152 ----------------------------------
9154 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
9156 Store_Actions_In_Scope
(After
, L
);
9157 end Store_After_Actions_In_Scope
;
9159 -----------------------------------
9160 -- Store_Before_Actions_In_Scope --
9161 -----------------------------------
9163 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
9165 Store_Actions_In_Scope
(Before
, L
);
9166 end Store_Before_Actions_In_Scope
;
9168 -----------------------------------
9169 -- Store_Cleanup_Actions_In_Scope --
9170 -----------------------------------
9172 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
9174 Store_Actions_In_Scope
(Cleanup
, L
);
9175 end Store_Cleanup_Actions_In_Scope
;
9181 procedure Unnest_Block
(Decl
: Node_Id
) is
9182 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
9184 Local_Body
: Node_Id
;
9185 Local_Call
: Node_Id
;
9186 Local_Proc
: Entity_Id
;
9187 Local_Scop
: Entity_Id
;
9190 Local_Scop
:= Entity
(Identifier
(Decl
));
9191 Ent
:= First_Entity
(Local_Scop
);
9193 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9196 Make_Subprogram_Body
(Loc
,
9198 Make_Procedure_Specification
(Loc
,
9199 Defining_Unit_Name
=> Local_Proc
),
9200 Declarations
=> Declarations
(Decl
),
9201 Handled_Statement_Sequence
=>
9202 Handled_Statement_Sequence
(Decl
));
9204 -- Handlers in the block may contain nested subprograms that require
9207 Check_Unnesting_In_Handlers
(Local_Body
);
9209 Rewrite
(Decl
, Local_Body
);
9211 Set_Has_Nested_Subprogram
(Local_Proc
);
9214 Make_Procedure_Call_Statement
(Loc
,
9215 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9217 Insert_After
(Decl
, Local_Call
);
9218 Analyze
(Local_Call
);
9220 -- The new subprogram has the same scope as the original block
9222 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9224 -- And the entity list of the new procedure is that of the block
9226 Set_First_Entity
(Local_Proc
, Ent
);
9228 -- Reset the scopes of all the entities to the new procedure
9230 while Present
(Ent
) loop
9231 Set_Scope
(Ent
, Local_Proc
);
9236 -------------------------
9237 -- Unnest_If_Statement --
9238 -------------------------
9240 procedure Unnest_If_Statement
(If_Stmt
: Node_Id
) is
9242 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
);
9243 -- A list of statements (that may be a list associated with a then,
9244 -- elsif, or else part of an if-statement) is traversed at the top
9245 -- level to determine whether it contains a subprogram body, and if so,
9246 -- the statements will be replaced with a new procedure body containing
9247 -- the statements followed by a call to the procedure. The individual
9248 -- statements may also be blocks, loops, or other if statements that
9249 -- themselves may require contain nested subprograms needing unnesting.
9251 procedure Check_Stmts_For_Subp_Unnesting
(Stmts
: in out List_Id
) is
9252 Subp_Found
: Boolean := False;
9255 if Is_Empty_List
(Stmts
) then
9260 Stmt
: Node_Id
:= First
(Stmts
);
9262 while Present
(Stmt
) loop
9263 if Nkind
(Stmt
) = N_Subprogram_Body
then
9272 -- The statements themselves may be blocks, loops, etc. that in turn
9273 -- contain nested subprograms requiring an unnesting transformation.
9274 -- We perform this traversal after looking for subprogram bodies, to
9275 -- avoid considering procedures created for one of those statements
9276 -- (such as a block rewritten as a procedure) as a nested subprogram
9277 -- of the statement list (which could result in an unneeded wrapper
9280 Check_Unnesting_In_Decls_Or_Stmts
(Stmts
);
9282 -- If there was a top-level subprogram body in the statement list,
9283 -- then perform an unnesting transformation on the list by replacing
9284 -- the statements with a wrapper procedure body containing the
9285 -- original statements followed by a call to that procedure.
9288 Unnest_Statement_List
(Stmts
);
9290 end Check_Stmts_For_Subp_Unnesting
;
9294 Then_Stmts
: List_Id
:= Then_Statements
(If_Stmt
);
9295 Else_Stmts
: List_Id
:= Else_Statements
(If_Stmt
);
9297 -- Start of processing for Unnest_If_Statement
9300 Check_Stmts_For_Subp_Unnesting
(Then_Stmts
);
9301 Set_Then_Statements
(If_Stmt
, Then_Stmts
);
9303 if not Is_Empty_List
(Elsif_Parts
(If_Stmt
)) then
9305 Elsif_Part
: Node_Id
:=
9306 First
(Elsif_Parts
(If_Stmt
));
9307 Elsif_Stmts
: List_Id
;
9309 while Present
(Elsif_Part
) loop
9310 Elsif_Stmts
:= Then_Statements
(Elsif_Part
);
9312 Check_Stmts_For_Subp_Unnesting
(Elsif_Stmts
);
9313 Set_Then_Statements
(Elsif_Part
, Elsif_Stmts
);
9320 Check_Stmts_For_Subp_Unnesting
(Else_Stmts
);
9321 Set_Else_Statements
(If_Stmt
, Else_Stmts
);
9322 end Unnest_If_Statement
;
9328 procedure Unnest_Loop
(Loop_Stmt
: Node_Id
) is
9329 Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
9331 Local_Body
: Node_Id
;
9332 Local_Call
: Node_Id
;
9333 Local_Proc
: Entity_Id
;
9334 Local_Scop
: Entity_Id
;
9335 Loop_Copy
: constant Node_Id
:=
9336 Relocate_Node
(Loop_Stmt
);
9338 Local_Scop
:= Entity
(Identifier
(Loop_Stmt
));
9339 Ent
:= First_Entity
(Local_Scop
);
9341 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9344 Make_Subprogram_Body
(Loc
,
9346 Make_Procedure_Specification
(Loc
,
9347 Defining_Unit_Name
=> Local_Proc
),
9348 Declarations
=> Empty_List
,
9349 Handled_Statement_Sequence
=>
9350 Make_Handled_Sequence_Of_Statements
(Loc
,
9351 Statements
=> New_List
(Loop_Copy
)));
9353 Rewrite
(Loop_Stmt
, Local_Body
);
9354 Analyze
(Loop_Stmt
);
9356 Set_Has_Nested_Subprogram
(Local_Proc
);
9359 Make_Procedure_Call_Statement
(Loc
,
9360 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9362 Insert_After
(Loop_Stmt
, Local_Call
);
9363 Analyze
(Local_Call
);
9365 -- New procedure has the same scope as the original loop, and the scope
9366 -- of the loop is the new procedure.
9368 Set_Scope
(Local_Proc
, Scope
(Local_Scop
));
9369 Set_Scope
(Local_Scop
, Local_Proc
);
9371 -- The entity list of the new procedure is that of the loop
9373 Set_First_Entity
(Local_Proc
, Ent
);
9375 -- Note that the entities associated with the loop don't need to have
9376 -- their Scope fields reset, since they're still associated with the
9377 -- same loop entity that now belongs to the copied loop statement.
9380 ---------------------------
9381 -- Unnest_Statement_List --
9382 ---------------------------
9384 procedure Unnest_Statement_List
(Stmts
: in out List_Id
) is
9385 Loc
: constant Source_Ptr
:= Sloc
(First
(Stmts
));
9386 Local_Body
: Node_Id
;
9387 Local_Call
: Node_Id
;
9388 Local_Proc
: Entity_Id
;
9389 New_Stmts
: constant List_Id
:= Empty_List
;
9392 Local_Proc
:= Make_Temporary
(Loc
, 'P');
9395 Make_Subprogram_Body
(Loc
,
9397 Make_Procedure_Specification
(Loc
,
9398 Defining_Unit_Name
=> Local_Proc
),
9399 Declarations
=> Empty_List
,
9400 Handled_Statement_Sequence
=>
9401 Make_Handled_Sequence_Of_Statements
(Loc
,
9402 Statements
=> Stmts
));
9404 Append_To
(New_Stmts
, Local_Body
);
9406 Analyze
(Local_Body
);
9408 Set_Has_Nested_Subprogram
(Local_Proc
);
9411 Make_Procedure_Call_Statement
(Loc
,
9412 Name
=> New_Occurrence_Of
(Local_Proc
, Loc
));
9414 Append_To
(New_Stmts
, Local_Call
);
9415 Analyze
(Local_Call
);
9417 -- Traverse the statements, and for any that are declarations or
9418 -- subprogram bodies that have entities, set the Scope of those
9419 -- entities to the new procedure's Entity_Id.
9422 Stmt
: Node_Id
:= First
(Stmts
);
9425 while Present
(Stmt
) loop
9426 case Nkind
(Stmt
) is
9428 | N_Renaming_Declaration
9430 Set_Scope
(Defining_Identifier
(Stmt
), Local_Proc
);
9432 when N_Subprogram_Body
=>
9434 (Defining_Unit_Name
(Specification
(Stmt
)), Local_Proc
);
9445 end Unnest_Statement_List
;
9447 --------------------------------
9448 -- Wrap_Transient_Declaration --
9449 --------------------------------
9451 -- If a transient scope has been established during the processing of the
9452 -- Expression of an Object_Declaration, it is not possible to wrap the
9453 -- declaration into a transient block as usual case, otherwise the object
9454 -- would be itself declared in the wrong scope. Therefore, all entities (if
9455 -- any) defined in the transient block are moved to the proper enclosing
9456 -- scope. Furthermore, if they are controlled variables they are finalized
9457 -- right after the declaration. The finalization list of the transient
9458 -- scope is defined as a renaming of the enclosing one so during their
9459 -- initialization they will be attached to the proper finalization list.
9460 -- For instance, the following declaration :
9462 -- X : Typ := F (G (A), G (B));
9464 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9465 -- is expanded into :
9467 -- X : Typ := [ complex Expression-Action ];
9468 -- [Deep_]Finalize (_v1);
9469 -- [Deep_]Finalize (_v2);
9471 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
9476 Curr_S
:= Current_Scope
;
9477 Encl_S
:= Scope
(Curr_S
);
9479 -- Insert all actions including cleanup generated while analyzing or
9480 -- expanding the transient context back into the tree. Manage the
9481 -- secondary stack when the object declaration appears in a library
9482 -- level package [body].
9484 Insert_Actions_In_Scope_Around
9488 Uses_Sec_Stack
(Curr_S
)
9489 and then Nkind
(N
) = N_Object_Declaration
9490 and then Ekind
(Encl_S
) in E_Package | E_Package_Body
9491 and then Is_Library_Level_Entity
(Encl_S
));
9494 -- Relocate local entities declared within the transient scope to the
9495 -- enclosing scope. This action sets their Is_Public flag accordingly.
9497 Transfer_Entities
(Curr_S
, Encl_S
);
9499 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9500 -- is properly released upon exiting the said scope.
9502 if Uses_Sec_Stack
(Curr_S
) then
9503 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
9505 -- Do not mark a function that returns on the secondary stack as the
9506 -- reclamation is done by the caller.
9508 if Ekind
(Curr_S
) = E_Function
9509 and then Needs_Secondary_Stack
(Etype
(Curr_S
))
9513 -- Otherwise mark the enclosing dynamic scope
9516 Set_Uses_Sec_Stack
(Curr_S
);
9517 Check_Restriction
(No_Secondary_Stack
, N
);
9520 end Wrap_Transient_Declaration
;
9522 -------------------------------
9523 -- Wrap_Transient_Expression --
9524 -------------------------------
9526 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
9527 Loc
: constant Source_Ptr
:= Sloc
(N
);
9528 Expr
: Node_Id
:= Relocate_Node
(N
);
9529 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
9530 Typ
: constant Entity_Id
:= Etype
(N
);
9537 -- M : constant Mark_Id := SS_Mark;
9538 -- procedure Finalizer is ... (See Build_Finalizer)
9541 -- Temp := <Expr>; -- general case
9542 -- Temp := (if <Expr> then True else False); -- boolean case
9548 -- A special case is made for Boolean expressions so that the back end
9549 -- knows to generate a conditional branch instruction, if running with
9550 -- -fpreserve-control-flow. This ensures that a control-flow change
9551 -- signaling the decision outcome occurs before the cleanup actions.
9553 if Opt
.Suppress_Control_Flow_Optimizations
9554 and then Is_Boolean_Type
(Typ
)
9557 Make_If_Expression
(Loc
,
9558 Expressions
=> New_List
(
9560 New_Occurrence_Of
(Standard_True
, Loc
),
9561 New_Occurrence_Of
(Standard_False
, Loc
)));
9564 Insert_Actions
(N
, New_List
(
9565 Make_Object_Declaration
(Loc
,
9566 Defining_Identifier
=> Temp
,
9567 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
9569 Make_Transient_Block
(Loc
,
9571 Make_Assignment_Statement
(Loc
,
9572 Name
=> New_Occurrence_Of
(Temp
, Loc
),
9573 Expression
=> Expr
),
9574 Par
=> Parent
(N
))));
9576 if Debug_Generated_Code
then
9577 Set_Debug_Info_Needed
(Temp
);
9580 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
9581 Analyze_And_Resolve
(N
, Typ
);
9582 end Wrap_Transient_Expression
;
9584 ------------------------------
9585 -- Wrap_Transient_Statement --
9586 ------------------------------
9588 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
9589 Loc
: constant Source_Ptr
:= Sloc
(N
);
9590 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
9595 -- M : constant Mark_Id := SS_Mark;
9596 -- procedure Finalizer is ... (See Build_Finalizer)
9606 Make_Transient_Block
(Loc
,
9608 Par
=> Parent
(N
)));
9610 -- With the scope stack back to normal, we can call analyze on the
9611 -- resulting block. At this point, the transient scope is being
9612 -- treated like a perfectly normal scope, so there is nothing
9613 -- special about it.
9615 -- Note: Wrap_Transient_Statement is called with the node already
9616 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9617 -- otherwise we would get a recursive processing of the node when
9618 -- we do this Analyze call.
9621 end Wrap_Transient_Statement
;