1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Ch11; use Exp_Ch11;
38 with Exp_Dbug; use Exp_Dbug;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Disp; use Exp_Disp;
41 with Exp_Prag; use Exp_Prag;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Output; use Output;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
53 with Sinfo; use Sinfo;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch7; use Sem_Ch7;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Res; use Sem_Res;
60 with Sem_Util; use Sem_Util;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Tbuild; use Tbuild;
64 with Ttypes; use Ttypes;
65 with Uintp; use Uintp;
67 package body Exp_Ch7 is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Transient_Context (N : Node_Id) return Node_Id;
129 -- Locate a suitable context for arbitrary node N which may need to be
130 -- serviced by a transient scope. Return Empty if no suitable context is
133 procedure Insert_Actions_In_Scope_Around
136 Manage_SS : Boolean);
137 -- Insert the before-actions kept in the scope stack before N, and the
138 -- after-actions after N, which must be a member of a list. If flag Clean
139 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
140 -- calls to mark and release the secondary stack.
142 function Make_Transient_Block
145 Par : Node_Id) return Node_Id;
146 -- Action is a single statement or object declaration. Par is the proper
147 -- parent of the generated block. Create a transient block whose name is
148 -- the current scope and the only handled statement is Action. If Action
149 -- involves controlled objects or secondary stack usage, the corresponding
150 -- cleanup actions are performed at the end of the block.
152 procedure Set_Node_To_Be_Wrapped (N : Node_Id);
153 -- Set the field Node_To_Be_Wrapped of the current scope
155 -- ??? The entire comment needs to be rewritten
156 -- ??? which entire comment?
158 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
159 -- Shared processing for Store_xxx_Actions_In_Scope
161 -----------------------------
162 -- Finalization Management --
163 -----------------------------
165 -- This part describe how Initialization/Adjustment/Finalization procedures
166 -- are generated and called. Two cases must be considered, types that are
167 -- Controlled (Is_Controlled flag set) and composite types that contain
168 -- controlled components (Has_Controlled_Component flag set). In the first
169 -- case the procedures to call are the user-defined primitive operations
170 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
171 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
172 -- of calling the former procedures on the controlled components.
174 -- For records with Has_Controlled_Component set, a hidden "controller"
175 -- component is inserted. This controller component contains its own
176 -- finalization list on which all controlled components are attached
177 -- creating an indirection on the upper-level Finalization list. This
178 -- technique facilitates the management of objects whose number of
179 -- controlled components changes during execution. This controller
180 -- component is itself controlled and is attached to the upper-level
181 -- finalization chain. Its adjust primitive is in charge of calling adjust
182 -- on the components and adjusting the finalization pointer to match their
183 -- new location (see a-finali.adb).
185 -- It is not possible to use a similar technique for arrays that have
186 -- Has_Controlled_Component set. In this case, deep procedures are
187 -- generated that call initialize/adjust/finalize + attachment or
188 -- detachment on the finalization list for all component.
190 -- Initialize calls: they are generated for declarations or dynamic
191 -- allocations of Controlled objects with no initial value. They are always
192 -- followed by an attachment to the current Finalization Chain. For the
193 -- dynamic allocation case this the chain attached to the scope of the
194 -- access type definition otherwise, this is the chain of the current
197 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
198 -- or dynamic allocations of Controlled objects with an initial value.
199 -- (2) after an assignment. In the first case they are followed by an
200 -- attachment to the final chain, in the second case they are not.
202 -- Finalization Calls: They are generated on (1) scope exit, (2)
203 -- assignments, (3) unchecked deallocations. In case (3) they have to
204 -- be detached from the final chain, in case (2) they must not and in
205 -- case (1) this is not important since we are exiting the scope anyway.
209 -- Type extensions will have a new record controller at each derivation
210 -- level containing controlled components. The record controller for
211 -- the parent/ancestor is attached to the finalization list of the
212 -- extension's record controller (i.e. the parent is like a component
213 -- of the extension).
215 -- For types that are both Is_Controlled and Has_Controlled_Components,
216 -- the record controller and the object itself are handled separately.
217 -- It could seem simpler to attach the object at the end of its record
218 -- controller but this would not tackle view conversions properly.
220 -- A classwide type can always potentially have controlled components
221 -- but the record controller of the corresponding actual type may not
222 -- be known at compile time so the dispatch table contains a special
223 -- field that allows computation of the offset of the record controller
224 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
226 -- Here is a simple example of the expansion of a controlled block :
230 -- Y : Controlled := Init;
236 -- Z : R := (C => X);
246 -- _L : System.FI.Finalizable_Ptr;
248 -- procedure _Clean is
251 -- System.FI.Finalize_List (_L);
259 -- Attach_To_Final_List (_L, Finalizable (X), 1);
260 -- at end: Abort_Undefer;
261 -- Y : Controlled := Init;
263 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
271 -- Deep_Initialize (W, _L, 1);
272 -- at end: Abort_Under;
273 -- Z : R := (C => X);
274 -- Deep_Adjust (Z, _L, 1);
278 -- Deep_Finalize (W, False);
279 -- <save W's final pointers>
281 -- <restore W's final pointers>
282 -- Deep_Adjust (W, _L, 0);
287 type Final_Primitives is
288 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
289 -- This enumeration type is defined in order to ease sharing code for
290 -- building finalization procedures for composite types.
292 Name_Of : constant array (Final_Primitives) of Name_Id :=
293 (Initialize_Case => Name_Initialize,
294 Adjust_Case => Name_Adjust,
295 Finalize_Case => Name_Finalize,
296 Address_Case => Name_Finalize_Address);
297 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
298 (Initialize_Case => TSS_Deep_Initialize,
299 Adjust_Case => TSS_Deep_Adjust,
300 Finalize_Case => TSS_Deep_Finalize,
301 Address_Case => TSS_Finalize_Address);
303 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
304 -- Determine whether access type Typ may have a finalization master
306 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
307 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
308 -- Has_Controlled_Component set and store them using the TSS mechanism.
310 function Build_Cleanup_Statements
312 Additional_Cleanup : List_Id) return List_Id;
313 -- Create the cleanup calls for an asynchronous call block, task master,
314 -- protected subprogram body, task allocation block or task body, or
315 -- additional cleanup actions parked on a transient block. If the context
316 -- does not contain the above constructs, the routine returns an empty
319 procedure Build_Finalizer
321 Clean_Stmts : List_Id;
324 Defer_Abort : Boolean;
325 Fin_Id : out Entity_Id);
326 -- N may denote an accept statement, block, entry body, package body,
327 -- package spec, protected body, subprogram body, or a task body. Create
328 -- a procedure which contains finalization calls for all controlled objects
329 -- declared in the declarative or statement region of N. The calls are
330 -- built in reverse order relative to the original declarations. In the
331 -- case of a task body, the routine delays the creation of the finalizer
332 -- until all statements have been moved to the task body procedure.
333 -- Clean_Stmts may contain additional context-dependent code used to abort
334 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
335 -- Mark_Id is the secondary stack used in the current context or Empty if
336 -- missing. Top_Decls is the list on which the declaration of the finalizer
337 -- is attached in the non-package case. Defer_Abort indicates that the
338 -- statements passed in perform actions that require abort to be deferred,
339 -- such as for task termination. Fin_Id is the finalizer declaration
342 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
343 -- N is a construct which contains a handled sequence of statements, Fin_Id
344 -- is the entity of a finalizer. Create an At_End handler which covers the
345 -- statements of N and calls Fin_Id. If the handled statement sequence has
346 -- an exception handler, the statements will be wrapped in a block to avoid
347 -- unwanted interaction with the new At_End handler.
349 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
350 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
351 -- Has_Component_Component set and store them using the TSS mechanism.
353 -------------------------------------------
354 -- Unnesting procedures for CCG and LLVM --
355 -------------------------------------------
357 -- Expansion generates subprograms for controlled types management that
358 -- may appear in declarative lists in package declarations and bodies.
359 -- These subprograms appear within generated blocks that contain local
360 -- declarations and a call to finalization procedures. To ensure that
361 -- such subprograms get activation records when needed, we transform the
362 -- block into a procedure body, followed by a call to it in the same
365 procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
366 -- The statement part of a package body that is a compilation unit may
367 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
368 -- Mode such subprograms must be handled as nested inside the (implicit)
369 -- elaboration procedure that executes that statement part. To handle
370 -- properly uplevel references we construct that subprogram explicitly,
371 -- to contain blocks and inner subprograms, The statement part becomes
372 -- a call to this subprogram. This is only done if blocks are present
373 -- in the statement list of the body. (It would be nice to unify this
374 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
375 -- they're doing very similar work, but are structured differently. ???)
377 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
378 -- Similarly, the declarations or statements in library-level packages may
379 -- have created blocks with nested subprograms. Such a block must be
380 -- transformed into a procedure followed by a call to it, so that unnesting
381 -- can handle uplevel references within these nested subprograms (typically
382 -- subprograms that handle finalization actions). This also applies to
383 -- nested packages, including instantiations, in which case it must
384 -- recursively process inner bodies.
386 procedure Check_Unnesting_In_Handlers (N : Node_Id);
387 -- Similarly, check for blocks with nested subprograms occurring within
388 -- a set of exception handlers associated with a package body N.
390 procedure Unnest_Block (Decl : Node_Id);
391 -- Blocks that contain nested subprograms with up-level references need to
392 -- create activation records for them. We do this by rewriting the block as
393 -- a procedure, followed by a call to it in the same declarative list, to
394 -- replicate the semantics of the original block.
396 -- A common source for such block is a transient block created for a
397 -- construct (declaration, assignment, etc.) that involves controlled
398 -- actions or secondary-stack management, in which case the nested
399 -- subprogram is a finalizer.
401 procedure Unnest_Loop (Loop_Stmt : Node_Id);
402 -- Top-level Loops that contain nested subprograms with up-level references
403 -- need to have activation records. We do this by rewriting the loop as a
404 -- procedure containing the loop, followed by a call to the procedure in
405 -- the same library-level declarative list, to replicate the semantics of
406 -- the original loop. Such loops can occur due to aggregate expansions and
409 procedure Check_Visibly_Controlled
410 (Prim : Final_Primitives;
412 E : in out Entity_Id;
413 Cref : in out Node_Id);
414 -- The controlled operation declared for a derived type may not be
415 -- overriding, if the controlled operations of the parent type are hidden,
416 -- for example when the parent is a private type whose full view is
417 -- controlled. For other primitive operations we modify the name of the
418 -- operation to indicate that it is not overriding, but this is not
419 -- possible for Initialize, etc. because they have to be retrievable by
420 -- name. Before generating the proper call to one of these operations we
421 -- check whether Typ is known to be controlled at the point of definition.
422 -- If it is not then we must retrieve the hidden operation of the parent
423 -- and use it instead. This is one case that might be solved more cleanly
424 -- once Overriding pragmas or declarations are in place.
426 function Contains_Subprogram (Blk : Entity_Id) return Boolean;
427 -- Check recursively whether a loop or block contains a subprogram that
428 -- may need an activation record.
430 function Convert_View
433 Ind : Pos := 1) return Node_Id;
434 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
435 -- argument being passed to it. Ind indicates which formal of procedure
436 -- Proc we are trying to match. This function will, if necessary, generate
437 -- a conversion between the partial and full view of Arg to match the type
438 -- of the formal of Proc, or force a conversion to the class-wide type in
439 -- the case where the operation is abstract.
441 function Enclosing_Function (E : Entity_Id) return Entity_Id;
442 -- Given an arbitrary entity, traverse the scope chain looking for the
443 -- first enclosing function. Return Empty if no function was found.
449 Skip_Self : Boolean := False) return Node_Id;
450 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
451 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
452 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
453 -- action has an effect on the components only (if any).
455 function Make_Deep_Proc
456 (Prim : Final_Primitives;
458 Stmts : List_Id) return Node_Id;
459 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
460 -- Deep_Finalize procedures according to the first parameter, these
461 -- procedures operate on the type Typ. The Stmts parameter gives the body
464 function Make_Deep_Array_Body
465 (Prim : Final_Primitives;
466 Typ : Entity_Id) return List_Id;
467 -- This function generates the list of statements for implementing
468 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
469 -- the first parameter, these procedures operate on the array type Typ.
471 function Make_Deep_Record_Body
472 (Prim : Final_Primitives;
474 Is_Local : Boolean := False) return List_Id;
475 -- This function generates the list of statements for implementing
476 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
477 -- the first parameter, these procedures operate on the record type Typ.
478 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
479 -- whether the inner logic should be dictated by state counters.
481 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
482 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
483 -- Make_Deep_Record_Body. Generate the following statements:
486 -- type Acc_Typ is access all Typ;
487 -- for Acc_Typ'Storage_Size use 0;
489 -- [Deep_]Finalize (Acc_Typ (V).all);
492 --------------------------------
493 -- Allows_Finalization_Master --
494 --------------------------------
496 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
497 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
498 -- Determine whether entity E is inside a wrapper package created for
499 -- an instance of Ada.Unchecked_Deallocation.
501 ------------------------------
502 -- In_Deallocation_Instance --
503 ------------------------------
505 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
506 Pkg : constant Entity_Id := Scope (E);
507 Par : Node_Id := Empty;
510 if Ekind (Pkg) = E_Package
511 and then Present (Related_Instance (Pkg))
512 and then Ekind (Related_Instance (Pkg)) = E_Procedure
514 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
518 and then Chars (Par) = Name_Unchecked_Deallocation
519 and then Chars (Scope (Par)) = Name_Ada
520 and then Scope (Scope (Par)) = Standard_Standard;
524 end In_Deallocation_Instance;
528 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
529 Ptr_Typ : constant Entity_Id :=
530 Root_Type_Of_Full_View (Base_Type (Typ));
532 -- Start of processing for Allows_Finalization_Master
535 -- Certain run-time configurations and targets do not provide support
536 -- for controlled types and therefore do not need masters.
538 if Restriction_Active (No_Finalization) then
541 -- Do not consider C and C++ types since it is assumed that the non-Ada
542 -- side will handle their cleanup.
544 elsif Convention (Desig_Typ) = Convention_C
545 or else Convention (Desig_Typ) = Convention_CPP
549 -- Do not consider an access type that returns on the secondary stack
551 elsif Present (Associated_Storage_Pool (Ptr_Typ))
552 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
556 -- Do not consider an access type that can never allocate an object
558 elsif No_Pool_Assigned (Ptr_Typ) then
561 -- Do not consider an access type coming from an Unchecked_Deallocation
562 -- instance. Even though the designated type may be controlled, the
563 -- access type will never participate in any allocations.
565 elsif In_Deallocation_Instance (Ptr_Typ) then
568 -- Do not consider a non-library access type when No_Nested_Finalization
569 -- is in effect since finalization masters are controlled objects and if
570 -- created will violate the restriction.
572 elsif Restriction_Active (No_Nested_Finalization)
573 and then not Is_Library_Level_Entity (Ptr_Typ)
577 -- Do not consider an access type subject to pragma No_Heap_Finalization
578 -- because objects allocated through such a type are not to be finalized
579 -- when the access type goes out of scope.
581 elsif No_Heap_Finalization (Ptr_Typ) then
584 -- Do not create finalization masters in GNATprove mode because this
585 -- causes unwanted extra expansion. A compilation in this mode must
586 -- keep the tree as close as possible to the original sources.
588 elsif GNATprove_Mode then
591 -- Otherwise the access type may use a finalization master
596 end Allows_Finalization_Master;
598 ----------------------------
599 -- Build_Anonymous_Master --
600 ----------------------------
602 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
603 function Create_Anonymous_Master
604 (Desig_Typ : Entity_Id;
606 Unit_Decl : Node_Id) return Entity_Id;
607 -- Create a new anonymous master for access type Ptr_Typ with designated
608 -- type Desig_Typ. The declaration of the master and its initialization
609 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
610 -- the entity of Unit_Decl.
612 function Current_Anonymous_Master
613 (Desig_Typ : Entity_Id;
614 Unit_Id : Entity_Id) return Entity_Id;
615 -- Find an anonymous master declared within unit Unit_Id which services
616 -- designated type Desig_Typ. If there is no such master, return Empty.
618 -----------------------------
619 -- Create_Anonymous_Master --
620 -----------------------------
622 function Create_Anonymous_Master
623 (Desig_Typ : Entity_Id;
625 Unit_Decl : Node_Id) return Entity_Id
627 Loc : constant Source_Ptr := Sloc (Unit_Id);
638 -- <FM_Id> : Finalization_Master;
640 FM_Id := Make_Temporary (Loc, 'A');
643 Make_Object_Declaration (Loc,
644 Defining_Identifier => FM_Id,
646 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
650 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
653 Make_Procedure_Call_Statement (Loc,
655 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
656 Parameter_Associations => New_List (
657 New_Occurrence_Of (FM_Id, Loc),
658 Make_Attribute_Reference (Loc,
660 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
661 Attribute_Name => Name_Unrestricted_Access)));
663 -- Find the declarative list of the unit
665 if Nkind (Unit_Decl) = N_Package_Declaration then
666 Unit_Spec := Specification (Unit_Decl);
667 Decls := Visible_Declarations (Unit_Spec);
671 Set_Visible_Declarations (Unit_Spec, Decls);
674 -- Package body or subprogram case
676 -- ??? A subprogram spec or body that acts as a compilation unit may
677 -- contain a formal parameter of an anonymous access-to-controlled
678 -- type initialized by an allocator.
680 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
682 -- There is no suitable place to create the master as the subprogram
683 -- is not in a declarative list.
686 Decls := Declarations (Unit_Decl);
690 Set_Declarations (Unit_Decl, Decls);
694 Prepend_To (Decls, FM_Init);
695 Prepend_To (Decls, FM_Decl);
697 -- Use the scope of the unit when analyzing the declaration of the
698 -- master and its initialization actions.
700 Push_Scope (Unit_Id);
705 -- Mark the master as servicing this specific designated type
707 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
709 -- Include the anonymous master in the list of existing masters which
710 -- appear in this unit. This effectively creates a mapping between a
711 -- master and a designated type which in turn allows for the reuse of
712 -- masters on a per-unit basis.
714 All_FMs := Anonymous_Masters (Unit_Id);
717 All_FMs := New_Elmt_List;
718 Set_Anonymous_Masters (Unit_Id, All_FMs);
721 Prepend_Elmt (FM_Id, All_FMs);
724 end Create_Anonymous_Master;
726 ------------------------------
727 -- Current_Anonymous_Master --
728 ------------------------------
730 function Current_Anonymous_Master
731 (Desig_Typ : Entity_Id;
732 Unit_Id : Entity_Id) return Entity_Id
734 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
739 -- Inspect the list of anonymous masters declared within the unit
740 -- looking for an existing master which services the same designated
743 if Present (All_FMs) then
744 FM_Elmt := First_Elmt (All_FMs);
745 while Present (FM_Elmt) loop
746 FM_Id := Node (FM_Elmt);
748 -- The currect master services the same designated type. As a
749 -- result the master can be reused and associated with another
750 -- anonymous access-to-controlled type.
752 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
761 end Current_Anonymous_Master;
765 Desig_Typ : Entity_Id;
767 Priv_View : Entity_Id;
771 -- Start of processing for Build_Anonymous_Master
774 -- Nothing to do if the circumstances do not allow for a finalization
777 if not Allows_Finalization_Master (Ptr_Typ) then
781 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
782 Unit_Id := Unique_Defining_Entity (Unit_Decl);
784 -- The compilation unit is a package instantiation. In this case the
785 -- anonymous master is associated with the package spec as both the
786 -- spec and body appear at the same level.
788 if Nkind (Unit_Decl) = N_Package_Body
789 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
791 Unit_Id := Corresponding_Spec (Unit_Decl);
792 Unit_Decl := Unit_Declaration_Node (Unit_Id);
795 -- Use the initial declaration of the designated type when it denotes
796 -- the full view of an incomplete or private type. This ensures that
797 -- types with one and two views are treated the same.
799 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
800 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
802 if Present (Priv_View) then
803 Desig_Typ := Priv_View;
806 -- Determine whether the current semantic unit already has an anonymous
807 -- master which services the designated type.
809 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
811 -- If this is not the case, create a new master
814 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
817 Set_Finalization_Master (Ptr_Typ, FM_Id);
818 end Build_Anonymous_Master;
820 ----------------------------
821 -- Build_Array_Deep_Procs --
822 ----------------------------
824 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
828 (Prim => Initialize_Case,
830 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
832 if not Is_Limited_View (Typ) then
835 (Prim => Adjust_Case,
837 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
840 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
841 -- suppressed since these routine will not be used.
843 if not Restriction_Active (No_Finalization) then
846 (Prim => Finalize_Case,
848 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
850 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
852 if not CodePeer_Mode then
855 (Prim => Address_Case,
857 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
860 end Build_Array_Deep_Procs;
862 ------------------------------
863 -- Build_Cleanup_Statements --
864 ------------------------------
866 function Build_Cleanup_Statements
868 Additional_Cleanup : List_Id) return List_Id
870 Is_Asynchronous_Call : constant Boolean :=
871 Nkind (N) = N_Block_Statement
872 and then Is_Asynchronous_Call_Block (N);
873 Is_Master : constant Boolean :=
874 Nkind (N) /= N_Entry_Body
875 and then Is_Task_Master (N);
876 Is_Protected_Body : constant Boolean :=
877 Nkind (N) = N_Subprogram_Body
878 and then Is_Protected_Subprogram_Body (N);
879 Is_Task_Allocation : constant Boolean :=
880 Nkind (N) = N_Block_Statement
881 and then Is_Task_Allocation_Block (N);
882 Is_Task_Body : constant Boolean :=
883 Nkind (Original_Node (N)) = N_Task_Body;
885 Loc : constant Source_Ptr := Sloc (N);
886 Stmts : constant List_Id := New_List;
890 if Restricted_Profile then
892 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
894 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
898 if Restriction_Active (No_Task_Hierarchy) = False then
899 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
902 -- Add statements to unlock the protected object parameter and to
903 -- undefer abort. If the context is a protected procedure and the object
904 -- has entries, call the entry service routine.
906 -- NOTE: The generated code references _object, a parameter to the
909 elsif Is_Protected_Body then
911 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
912 Conc_Typ : Entity_Id;
914 Param_Typ : Entity_Id;
917 -- Find the _object parameter representing the protected object
919 Param := First (Parameter_Specifications (Spec));
921 Param_Typ := Etype (Parameter_Type (Param));
923 if Ekind (Param_Typ) = E_Record_Type then
924 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
927 exit when No (Param) or else Present (Conc_Typ);
931 pragma Assert (Present (Param));
933 -- Historical note: In earlier versions of GNAT, there was code
934 -- at this point to generate stuff to service entry queues. It is
935 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
937 Build_Protected_Subprogram_Call_Cleanup
938 (Specification (N), Conc_Typ, Loc, Stmts);
941 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
942 -- tasks. Other unactivated tasks are completed by Complete_Task or
945 -- NOTE: The generated code references _chain, a local object
947 elsif Is_Task_Allocation then
950 -- Expunge_Unactivated_Tasks (_chain);
952 -- where _chain is the list of tasks created by the allocator but not
953 -- yet activated. This list will be empty unless the block completes
957 Make_Procedure_Call_Statement (Loc,
960 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
961 Parameter_Associations => New_List (
962 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
964 -- Attempt to cancel an asynchronous entry call whenever the block which
965 -- contains the abortable part is exited.
967 -- NOTE: The generated code references Cnn, a local object
969 elsif Is_Asynchronous_Call then
971 Cancel_Param : constant Entity_Id :=
972 Entry_Cancel_Parameter (Entity (Identifier (N)));
975 -- If it is of type Communication_Block, this must be a protected
976 -- entry call. Generate:
978 -- if Enqueued (Cancel_Param) then
979 -- Cancel_Protected_Entry_Call (Cancel_Param);
982 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
984 Make_If_Statement (Loc,
986 Make_Function_Call (Loc,
988 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
989 Parameter_Associations => New_List (
990 New_Occurrence_Of (Cancel_Param, Loc))),
992 Then_Statements => New_List (
993 Make_Procedure_Call_Statement (Loc,
996 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
997 Parameter_Associations => New_List (
998 New_Occurrence_Of (Cancel_Param, Loc))))));
1000 -- Asynchronous delay, generate:
1001 -- Cancel_Async_Delay (Cancel_Param);
1003 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
1005 Make_Procedure_Call_Statement (Loc,
1007 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
1008 Parameter_Associations => New_List (
1009 Make_Attribute_Reference (Loc,
1011 New_Occurrence_Of (Cancel_Param, Loc),
1012 Attribute_Name => Name_Unchecked_Access))));
1014 -- Task entry call, generate:
1015 -- Cancel_Task_Entry_Call (Cancel_Param);
1019 Make_Procedure_Call_Statement (Loc,
1021 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
1022 Parameter_Associations => New_List (
1023 New_Occurrence_Of (Cancel_Param, Loc))));
1028 Append_List_To (Stmts, Additional_Cleanup);
1030 end Build_Cleanup_Statements;
1032 -----------------------------
1033 -- Build_Controlling_Procs --
1034 -----------------------------
1036 procedure Build_Controlling_Procs (Typ : Entity_Id) is
1038 if Is_Array_Type (Typ) then
1039 Build_Array_Deep_Procs (Typ);
1040 else pragma Assert (Is_Record_Type (Typ));
1041 Build_Record_Deep_Procs (Typ);
1043 end Build_Controlling_Procs;
1045 -----------------------------
1046 -- Build_Exception_Handler --
1047 -----------------------------
1049 function Build_Exception_Handler
1050 (Data : Finalization_Exception_Data;
1051 For_Library : Boolean := False) return Node_Id
1054 Proc_To_Call : Entity_Id;
1059 pragma Assert (Present (Data.Raised_Id));
1061 if Exception_Extra_Info
1062 or else (For_Library and not Restricted_Profile)
1064 if Exception_Extra_Info then
1068 -- Get_Current_Excep.all
1071 Make_Function_Call (Data.Loc,
1073 Make_Explicit_Dereference (Data.Loc,
1076 (RTE (RE_Get_Current_Excep), Data.Loc)));
1083 Except := Make_Null (Data.Loc);
1086 if For_Library and then not Restricted_Profile then
1087 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1088 Actuals := New_List (Except);
1091 Proc_To_Call := RTE (RE_Save_Occurrence);
1093 -- The dereference occurs only when Exception_Extra_Info is true,
1094 -- and therefore Except is not null.
1098 New_Occurrence_Of (Data.E_Id, Data.Loc),
1099 Make_Explicit_Dereference (Data.Loc, Except));
1105 -- if not Raised_Id then
1106 -- Raised_Id := True;
1108 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1110 -- Save_Library_Occurrence (Get_Current_Excep.all);
1115 Make_If_Statement (Data.Loc,
1117 Make_Op_Not (Data.Loc,
1118 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1120 Then_Statements => New_List (
1121 Make_Assignment_Statement (Data.Loc,
1122 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1123 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1125 Make_Procedure_Call_Statement (Data.Loc,
1127 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1128 Parameter_Associations => Actuals))));
1133 -- Raised_Id := True;
1136 Make_Assignment_Statement (Data.Loc,
1137 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1138 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1146 Make_Exception_Handler (Data.Loc,
1147 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1148 Statements => Stmts);
1149 end Build_Exception_Handler;
1151 -------------------------------
1152 -- Build_Finalization_Master --
1153 -------------------------------
1155 procedure Build_Finalization_Master
1157 For_Lib_Level : Boolean := False;
1158 For_Private : Boolean := False;
1159 Context_Scope : Entity_Id := Empty;
1160 Insertion_Node : Node_Id := Empty)
1162 procedure Add_Pending_Access_Type
1164 Ptr_Typ : Entity_Id);
1165 -- Add access type Ptr_Typ to the pending access type list for type Typ
1167 -----------------------------
1168 -- Add_Pending_Access_Type --
1169 -----------------------------
1171 procedure Add_Pending_Access_Type
1173 Ptr_Typ : Entity_Id)
1178 if Present (Pending_Access_Types (Typ)) then
1179 List := Pending_Access_Types (Typ);
1181 List := New_Elmt_List;
1182 Set_Pending_Access_Types (Typ, List);
1185 Prepend_Elmt (Ptr_Typ, List);
1186 end Add_Pending_Access_Type;
1190 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1192 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1193 -- A finalization master created for a named access type is associated
1194 -- with the full view (if applicable) as a consequence of freezing. The
1195 -- full view criteria does not apply to anonymous access types because
1196 -- those cannot have a private and a full view.
1198 -- Start of processing for Build_Finalization_Master
1201 -- Nothing to do if the circumstances do not allow for a finalization
1204 if not Allows_Finalization_Master (Typ) then
1207 -- Various machinery such as freezing may have already created a
1208 -- finalization master.
1210 elsif Present (Finalization_Master (Ptr_Typ)) then
1215 Actions : constant List_Id := New_List;
1216 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1217 Fin_Mas_Id : Entity_Id;
1218 Pool_Id : Entity_Id;
1221 -- Source access types use fixed master names since the master is
1222 -- inserted in the same source unit only once. The only exception to
1223 -- this are instances using the same access type as generic actual.
1225 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1227 Make_Defining_Identifier (Loc,
1228 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
1230 -- Internally generated access types use temporaries as their names
1231 -- due to possible collision with identical names coming from other
1235 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1238 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1241 -- <Ptr_Typ>FM : aliased Finalization_Master;
1244 Make_Object_Declaration (Loc,
1245 Defining_Identifier => Fin_Mas_Id,
1246 Aliased_Present => True,
1247 Object_Definition =>
1248 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
1250 -- Set the associated pool and primitive Finalize_Address of the new
1251 -- finalization master.
1253 -- The access type has a user-defined storage pool, use it
1255 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1256 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1258 -- Otherwise the default choice is the global storage pool
1261 Pool_Id := RTE (RE_Global_Pool_Object);
1262 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1266 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1269 Make_Procedure_Call_Statement (Loc,
1271 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
1272 Parameter_Associations => New_List (
1273 New_Occurrence_Of (Fin_Mas_Id, Loc),
1274 Make_Attribute_Reference (Loc,
1275 Prefix => New_Occurrence_Of (Pool_Id, Loc),
1276 Attribute_Name => Name_Unrestricted_Access))));
1278 -- Finalize_Address is not generated in CodePeer mode because the
1279 -- body contains address arithmetic. Skip this step.
1281 if CodePeer_Mode then
1284 -- Associate the Finalize_Address primitive of the designated type
1285 -- with the finalization master of the access type. The designated
1286 -- type must be forzen as Finalize_Address is generated when the
1287 -- freeze node is expanded.
1289 elsif Is_Frozen (Desig_Typ)
1290 and then Present (Finalize_Address (Desig_Typ))
1292 -- The finalization master of an anonymous access type may need
1293 -- to be inserted in a specific place in the tree. For instance:
1297 -- <finalization master of "access Comp_Typ">
1299 -- type Rec_Typ is record
1300 -- Comp : access Comp_Typ;
1303 -- <freeze node for Comp_Typ>
1304 -- <freeze node for Rec_Typ>
1306 -- Due to this oddity, the anonymous access type is stored for
1307 -- later processing (see below).
1309 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
1312 -- Set_Finalize_Address
1313 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1316 Make_Set_Finalize_Address_Call
1318 Ptr_Typ => Ptr_Typ));
1320 -- Otherwise the designated type is either anonymous access or a
1321 -- Taft-amendment type and has not been frozen. Store the access
1322 -- type for later processing (see Freeze_Type).
1325 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1328 -- A finalization master created for an access designating a type
1329 -- with private components is inserted before a context-dependent
1334 -- At this point both the scope of the context and the insertion
1335 -- mode must be known.
1337 pragma Assert (Present (Context_Scope));
1338 pragma Assert (Present (Insertion_Node));
1340 Push_Scope (Context_Scope);
1342 -- Treat use clauses as declarations and insert directly in front
1345 if Nkind_In (Insertion_Node, N_Use_Package_Clause,
1348 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1350 Insert_Actions (Insertion_Node, Actions);
1355 -- The finalization master belongs to an access result type related
1356 -- to a build-in-place function call used to initialize a library
1357 -- level object. The master must be inserted in front of the access
1358 -- result type declaration denoted by Insertion_Node.
1360 elsif For_Lib_Level then
1361 pragma Assert (Present (Insertion_Node));
1362 Insert_Actions (Insertion_Node, Actions);
1364 -- Otherwise the finalization master and its initialization become a
1365 -- part of the freeze node.
1368 Append_Freeze_Actions (Ptr_Typ, Actions);
1371 end Build_Finalization_Master;
1373 ---------------------
1374 -- Build_Finalizer --
1375 ---------------------
1377 procedure Build_Finalizer
1379 Clean_Stmts : List_Id;
1380 Mark_Id : Entity_Id;
1381 Top_Decls : List_Id;
1382 Defer_Abort : Boolean;
1383 Fin_Id : out Entity_Id)
1385 Acts_As_Clean : constant Boolean :=
1388 (Present (Clean_Stmts)
1389 and then Is_Non_Empty_List (Clean_Stmts));
1391 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1392 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1393 For_Package : constant Boolean :=
1394 For_Package_Body or else For_Package_Spec;
1395 Loc : constant Source_Ptr := Sloc (N);
1397 -- NOTE: Local variable declarations are conservative and do not create
1398 -- structures right from the start. Entities and lists are created once
1399 -- it has been established that N has at least one controlled object.
1401 Components_Built : Boolean := False;
1402 -- A flag used to avoid double initialization of entities and lists. If
1403 -- the flag is set then the following variables have been initialized:
1409 Counter_Id : Entity_Id := Empty;
1410 Counter_Val : Nat := 0;
1411 -- Name and value of the state counter
1413 Decls : List_Id := No_List;
1414 -- Declarative region of N (if available). If N is a package declaration
1415 -- Decls denotes the visible declarations.
1417 Finalizer_Data : Finalization_Exception_Data;
1418 -- Data for the exception
1420 Finalizer_Decls : List_Id := No_List;
1421 -- Local variable declarations. This list holds the label declarations
1422 -- of all jump block alternatives as well as the declaration of the
1423 -- local exception occurrence and the raised flag:
1424 -- E : Exception_Occurrence;
1425 -- Raised : Boolean := False;
1426 -- L<counter value> : label;
1428 Finalizer_Insert_Nod : Node_Id := Empty;
1429 -- Insertion point for the finalizer body. Depending on the context
1430 -- (Nkind of N) and the individual grouping of controlled objects, this
1431 -- node may denote a package declaration or body, package instantiation,
1432 -- block statement or a counter update statement.
1434 Finalizer_Stmts : List_Id := No_List;
1435 -- The statement list of the finalizer body. It contains the following:
1437 -- Abort_Defer; -- Added if abort is allowed
1438 -- <call to Prev_At_End> -- Added if exists
1439 -- <cleanup statements> -- Added if Acts_As_Clean
1440 -- <jump block> -- Added if Has_Ctrl_Objs
1441 -- <finalization statements> -- Added if Has_Ctrl_Objs
1442 -- <stack release> -- Added if Mark_Id exists
1443 -- Abort_Undefer; -- Added if abort is allowed
1445 Has_Ctrl_Objs : Boolean := False;
1446 -- A general flag which denotes whether N has at least one controlled
1449 Has_Tagged_Types : Boolean := False;
1450 -- A general flag which indicates whether N has at least one library-
1451 -- level tagged type declaration.
1453 HSS : Node_Id := Empty;
1454 -- The sequence of statements of N (if available)
1456 Jump_Alts : List_Id := No_List;
1457 -- Jump block alternatives. Depending on the value of the state counter,
1458 -- the control flow jumps to a sequence of finalization statements. This
1459 -- list contains the following:
1461 -- when <counter value> =>
1462 -- goto L<counter value>;
1464 Jump_Block_Insert_Nod : Node_Id := Empty;
1465 -- Specific point in the finalizer statements where the jump block is
1468 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1469 -- The last controlled construct encountered when processing the top
1470 -- level lists of N. This can be a nested package, an instantiation or
1471 -- an object declaration.
1473 Prev_At_End : Entity_Id := Empty;
1474 -- The previous at end procedure of the handled statements block of N
1476 Priv_Decls : List_Id := No_List;
1477 -- The private declarations of N if N is a package declaration
1479 Spec_Id : Entity_Id := Empty;
1480 Spec_Decls : List_Id := Top_Decls;
1481 Stmts : List_Id := No_List;
1483 Tagged_Type_Stmts : List_Id := No_List;
1484 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1485 -- tagged types found in N.
1487 -----------------------
1488 -- Local subprograms --
1489 -----------------------
1491 procedure Build_Components;
1492 -- Create all entites and initialize all lists used in the creation of
1495 procedure Create_Finalizer;
1496 -- Create the spec and body of the finalizer and insert them in the
1497 -- proper place in the tree depending on the context.
1499 procedure Process_Declarations
1501 Preprocess : Boolean := False;
1502 Top_Level : Boolean := False);
1503 -- Inspect a list of declarations or statements which may contain
1504 -- objects that need finalization. When flag Preprocess is set, the
1505 -- routine will simply count the total number of controlled objects in
1506 -- Decls. Flag Top_Level denotes whether the processing is done for
1507 -- objects in nested package declarations or instances.
1509 procedure Process_Object_Declaration
1511 Has_No_Init : Boolean := False;
1512 Is_Protected : Boolean := False);
1513 -- Generate all the machinery associated with the finalization of a
1514 -- single object. Flag Has_No_Init is used to denote certain contexts
1515 -- where Decl does not have initialization call(s). Flag Is_Protected
1516 -- is set when Decl denotes a simple protected object.
1518 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1519 -- Generate all the code necessary to unregister the external tag of a
1522 ----------------------
1523 -- Build_Components --
1524 ----------------------
1526 procedure Build_Components is
1527 Counter_Decl : Node_Id;
1528 Counter_Typ : Entity_Id;
1529 Counter_Typ_Decl : Node_Id;
1532 pragma Assert (Present (Decls));
1534 -- This routine might be invoked several times when dealing with
1535 -- constructs that have two lists (either two declarative regions
1536 -- or declarations and statements). Avoid double initialization.
1538 if Components_Built then
1542 Components_Built := True;
1544 if Has_Ctrl_Objs then
1546 -- Create entities for the counter, its type, the local exception
1547 -- and the raised flag.
1549 Counter_Id := Make_Temporary (Loc, 'C');
1550 Counter_Typ := Make_Temporary (Loc, 'T');
1552 Finalizer_Decls := New_List;
1554 Build_Object_Declarations
1555 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1557 -- Since the total number of controlled objects is always known,
1558 -- build a subtype of Natural with precise bounds. This allows
1559 -- the backend to optimize the case statement. Generate:
1561 -- subtype Tnn is Natural range 0 .. Counter_Val;
1564 Make_Subtype_Declaration (Loc,
1565 Defining_Identifier => Counter_Typ,
1566 Subtype_Indication =>
1567 Make_Subtype_Indication (Loc,
1568 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1570 Make_Range_Constraint (Loc,
1574 Make_Integer_Literal (Loc, Uint_0),
1576 Make_Integer_Literal (Loc, Counter_Val)))));
1578 -- Generate the declaration of the counter itself:
1580 -- Counter : Integer := 0;
1583 Make_Object_Declaration (Loc,
1584 Defining_Identifier => Counter_Id,
1585 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1586 Expression => Make_Integer_Literal (Loc, 0));
1588 -- Set the type of the counter explicitly to prevent errors when
1589 -- examining object declarations later on.
1591 Set_Etype (Counter_Id, Counter_Typ);
1593 -- The counter and its type are inserted before the source
1594 -- declarations of N.
1596 Prepend_To (Decls, Counter_Decl);
1597 Prepend_To (Decls, Counter_Typ_Decl);
1599 -- The counter and its associated type must be manually analyzed
1600 -- since N has already been analyzed. Use the scope of the spec
1601 -- when inserting in a package.
1604 Push_Scope (Spec_Id);
1605 Analyze (Counter_Typ_Decl);
1606 Analyze (Counter_Decl);
1610 Analyze (Counter_Typ_Decl);
1611 Analyze (Counter_Decl);
1614 Jump_Alts := New_List;
1617 -- If the context requires additional cleanup, the finalization
1618 -- machinery is added after the cleanup code.
1620 if Acts_As_Clean then
1621 Finalizer_Stmts := Clean_Stmts;
1622 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1624 Finalizer_Stmts := New_List;
1627 if Has_Tagged_Types then
1628 Tagged_Type_Stmts := New_List;
1630 end Build_Components;
1632 ----------------------
1633 -- Create_Finalizer --
1634 ----------------------
1636 procedure Create_Finalizer is
1637 function New_Finalizer_Name return Name_Id;
1638 -- Create a fully qualified name of a package spec or body finalizer.
1639 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1641 ------------------------
1642 -- New_Finalizer_Name --
1643 ------------------------
1645 function New_Finalizer_Name return Name_Id is
1646 procedure New_Finalizer_Name (Id : Entity_Id);
1647 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1648 -- has a non-standard scope, process the scope first.
1650 ------------------------
1651 -- New_Finalizer_Name --
1652 ------------------------
1654 procedure New_Finalizer_Name (Id : Entity_Id) is
1656 if Scope (Id) = Standard_Standard then
1657 Get_Name_String (Chars (Id));
1660 New_Finalizer_Name (Scope (Id));
1661 Add_Str_To_Name_Buffer ("__");
1662 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1664 end New_Finalizer_Name;
1666 -- Start of processing for New_Finalizer_Name
1669 -- Create the fully qualified name of the enclosing scope
1671 New_Finalizer_Name (Spec_Id);
1674 -- __finalize_[spec|body]
1676 Add_Str_To_Name_Buffer ("__finalize_");
1678 if For_Package_Spec then
1679 Add_Str_To_Name_Buffer ("spec");
1681 Add_Str_To_Name_Buffer ("body");
1685 end New_Finalizer_Name;
1689 Body_Id : Entity_Id;
1692 Jump_Block : Node_Id;
1694 Label_Id : Entity_Id;
1696 -- Start of processing for Create_Finalizer
1699 -- Step 1: Creation of the finalizer name
1701 -- Packages must use a distinct name for their finalizers since the
1702 -- binder will have to generate calls to them by name. The name is
1703 -- of the following form:
1705 -- xx__yy__finalize_[spec|body]
1708 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1709 Set_Has_Qualified_Name (Fin_Id);
1710 Set_Has_Fully_Qualified_Name (Fin_Id);
1712 -- The default name is _finalizer
1716 Make_Defining_Identifier (Loc,
1717 Chars => New_External_Name (Name_uFinalizer));
1719 -- The visibility semantics of AT_END handlers force a strange
1720 -- separation of spec and body for stack-related finalizers:
1722 -- declare : Enclosing_Scope
1723 -- procedure _finalizer;
1725 -- <controlled objects>
1726 -- procedure _finalizer is
1732 -- Both spec and body are within the same construct and scope, but
1733 -- the body is part of the handled sequence of statements. This
1734 -- placement confuses the elaboration mechanism on targets where
1735 -- AT_END handlers are expanded into "when all others" handlers:
1738 -- when all others =>
1739 -- _finalizer; -- appears to require elab checks
1744 -- Since the compiler guarantees that the body of a _finalizer is
1745 -- always inserted in the same construct where the AT_END handler
1746 -- resides, there is no need for elaboration checks.
1748 Set_Kill_Elaboration_Checks (Fin_Id);
1750 -- Inlining the finalizer produces a substantial speedup at -O2.
1751 -- It is inlined by default at -O3. Either way, it is called
1752 -- exactly twice (once on the normal path, and once for
1753 -- exceptions/abort), so this won't bloat the code too much.
1755 Set_Is_Inlined (Fin_Id);
1758 -- Step 2: Creation of the finalizer specification
1761 -- procedure Fin_Id;
1764 Make_Subprogram_Declaration (Loc,
1766 Make_Procedure_Specification (Loc,
1767 Defining_Unit_Name => Fin_Id));
1769 -- Step 3: Creation of the finalizer body
1771 if Has_Ctrl_Objs then
1773 -- Add L0, the default destination to the jump block
1775 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1776 Set_Entity (Label_Id,
1777 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1778 Label := Make_Label (Loc, Label_Id);
1783 Prepend_To (Finalizer_Decls,
1784 Make_Implicit_Label_Declaration (Loc,
1785 Defining_Identifier => Entity (Label_Id),
1786 Label_Construct => Label));
1792 Append_To (Jump_Alts,
1793 Make_Case_Statement_Alternative (Loc,
1794 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1795 Statements => New_List (
1796 Make_Goto_Statement (Loc,
1797 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1802 Append_To (Finalizer_Stmts, Label);
1804 -- Create the jump block which controls the finalization flow
1805 -- depending on the value of the state counter.
1808 Make_Case_Statement (Loc,
1809 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1810 Alternatives => Jump_Alts);
1812 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1813 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1815 Prepend_To (Finalizer_Stmts, Jump_Block);
1819 -- Add the library-level tagged type unregistration machinery before
1820 -- the jump block circuitry. This ensures that external tags will be
1821 -- removed even if a finalization exception occurs at some point.
1823 if Has_Tagged_Types then
1824 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1827 -- Add a call to the previous At_End handler if it exists. The call
1828 -- must always precede the jump block.
1830 if Present (Prev_At_End) then
1831 Prepend_To (Finalizer_Stmts,
1832 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1834 -- Clear the At_End handler since we have already generated the
1835 -- proper replacement call for it.
1837 Set_At_End_Proc (HSS, Empty);
1840 -- Release the secondary stack
1842 if Present (Mark_Id) then
1844 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
1847 -- If the context is a build-in-place function, the secondary
1848 -- stack must be released, unless the build-in-place function
1849 -- itself is returning on the secondary stack. Generate:
1851 -- if BIP_Alloc_Form /= Secondary_Stack then
1852 -- SS_Release (Mark_Id);
1855 -- Note that if the function returns on the secondary stack,
1856 -- then the responsibility of reclaiming the space is always
1857 -- left to the caller (recursively if needed).
1859 if Nkind (N) = N_Subprogram_Body then
1861 Spec_Id : constant Entity_Id :=
1862 Unique_Defining_Entity (N);
1863 BIP_SS : constant Boolean :=
1864 Is_Build_In_Place_Function (Spec_Id)
1865 and then Needs_BIP_Alloc_Form (Spec_Id);
1869 Make_If_Statement (Loc,
1874 (Build_In_Place_Formal
1875 (Spec_Id, BIP_Alloc_Form), Loc),
1877 Make_Integer_Literal (Loc,
1879 (BIP_Allocation_Form'Pos
1880 (Secondary_Stack)))),
1882 Then_Statements => New_List (Release));
1887 Append_To (Finalizer_Stmts, Release);
1891 -- Protect the statements with abort defer/undefer. This is only when
1892 -- aborts are allowed and the cleanup statements require deferral or
1893 -- there are controlled objects to be finalized. Note that the abort
1894 -- defer/undefer pair does not require an extra block because each
1895 -- finalization exception is caught in its corresponding finalization
1896 -- block. As a result, the call to Abort_Defer always takes place.
1898 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1899 Prepend_To (Finalizer_Stmts,
1900 Build_Runtime_Call (Loc, RE_Abort_Defer));
1902 Append_To (Finalizer_Stmts,
1903 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1906 -- The local exception does not need to be reraised for library-level
1907 -- finalizers. Note that this action must be carried out after object
1908 -- cleanup, secondary stack release, and abort undeferral. Generate:
1910 -- if Raised and then not Abort then
1911 -- Raise_From_Controlled_Operation (E);
1914 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1915 Append_To (Finalizer_Stmts,
1916 Build_Raise_Statement (Finalizer_Data));
1920 -- procedure Fin_Id is
1921 -- Abort : constant Boolean := Triggered_By_Abort;
1923 -- Abort : constant Boolean := False; -- no abort
1925 -- E : Exception_Occurrence; -- All added if flag
1926 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1932 -- Abort_Defer; -- Added if abort is allowed
1933 -- <call to Prev_At_End> -- Added if exists
1934 -- <cleanup statements> -- Added if Acts_As_Clean
1935 -- <jump block> -- Added if Has_Ctrl_Objs
1936 -- <finalization statements> -- Added if Has_Ctrl_Objs
1937 -- <stack release> -- Added if Mark_Id exists
1938 -- Abort_Undefer; -- Added if abort is allowed
1939 -- <exception propagation> -- Added if Has_Ctrl_Objs
1942 -- Create the body of the finalizer
1944 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1947 Set_Has_Qualified_Name (Body_Id);
1948 Set_Has_Fully_Qualified_Name (Body_Id);
1952 Make_Subprogram_Body (Loc,
1954 Make_Procedure_Specification (Loc,
1955 Defining_Unit_Name => Body_Id),
1956 Declarations => Finalizer_Decls,
1957 Handled_Statement_Sequence =>
1958 Make_Handled_Sequence_Of_Statements (Loc,
1959 Statements => Finalizer_Stmts));
1961 -- Step 4: Spec and body insertion, analysis
1965 -- If the package spec has private declarations, the finalizer
1966 -- body must be added to the end of the list in order to have
1967 -- visibility of all private controlled objects.
1969 if For_Package_Spec then
1970 if Present (Priv_Decls) then
1971 Append_To (Priv_Decls, Fin_Spec);
1972 Append_To (Priv_Decls, Fin_Body);
1974 Append_To (Decls, Fin_Spec);
1975 Append_To (Decls, Fin_Body);
1978 -- For package bodies, both the finalizer spec and body are
1979 -- inserted at the end of the package declarations.
1982 Append_To (Decls, Fin_Spec);
1983 Append_To (Decls, Fin_Body);
1986 -- Push the name of the package
1988 Push_Scope (Spec_Id);
1996 -- Create the spec for the finalizer. The At_End handler must be
1997 -- able to call the body which resides in a nested structure.
2001 -- procedure Fin_Id; -- Spec
2003 -- <objects and possibly statements>
2004 -- procedure Fin_Id is ... -- Body
2007 -- Fin_Id; -- At_End handler
2010 pragma Assert (Present (Spec_Decls));
2012 Append_To (Spec_Decls, Fin_Spec);
2015 -- When the finalizer acts solely as a cleanup routine, the body
2016 -- is inserted right after the spec.
2018 if Acts_As_Clean and not Has_Ctrl_Objs then
2019 Insert_After (Fin_Spec, Fin_Body);
2021 -- In all other cases the body is inserted after either:
2023 -- 1) The counter update statement of the last controlled object
2024 -- 2) The last top level nested controlled package
2025 -- 3) The last top level controlled instantiation
2028 -- Manually freeze the spec. This is somewhat of a hack because
2029 -- a subprogram is frozen when its body is seen and the freeze
2030 -- node appears right before the body. However, in this case,
2031 -- the spec must be frozen earlier since the At_End handler
2032 -- must be able to call it.
2035 -- procedure Fin_Id; -- Spec
2036 -- [Fin_Id] -- Freeze node
2040 -- Fin_Id; -- At_End handler
2043 Ensure_Freeze_Node (Fin_Id);
2044 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
2045 Set_Is_Frozen (Fin_Id);
2047 -- In the case where the last construct to contain a controlled
2048 -- object is either a nested package, an instantiation or a
2049 -- freeze node, the body must be inserted directly after the
2052 if Nkind_In (Last_Top_Level_Ctrl_Construct,
2054 N_Package_Declaration,
2057 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
2060 Insert_After (Finalizer_Insert_Nod, Fin_Body);
2063 Analyze (Fin_Body, Suppress => All_Checks);
2066 -- Never consider that the finalizer procedure is enabled Ghost, even
2067 -- when the corresponding unit is Ghost, as this would lead to an
2068 -- an external name with a ___ghost_ prefix that the binder cannot
2069 -- generate, as it has no knowledge of the Ghost status of units.
2071 Set_Is_Checked_Ghost_Entity (Fin_Id, False);
2072 end Create_Finalizer;
2074 --------------------------
2075 -- Process_Declarations --
2076 --------------------------
2078 procedure Process_Declarations
2080 Preprocess : Boolean := False;
2081 Top_Level : Boolean := False)
2086 Obj_Typ : Entity_Id;
2087 Pack_Id : Entity_Id;
2091 Old_Counter_Val : Nat;
2092 -- This variable is used to determine whether a nested package or
2093 -- instance contains at least one controlled object.
2095 procedure Processing_Actions
2096 (Has_No_Init : Boolean := False;
2097 Is_Protected : Boolean := False);
2098 -- Depending on the mode of operation of Process_Declarations, either
2099 -- increment the controlled object counter, set the controlled object
2100 -- flag and store the last top level construct or process the current
2101 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2102 -- the current declaration may not have initialization proc(s). Flag
2103 -- Is_Protected should be set when the current declaration denotes a
2104 -- simple protected object.
2106 ------------------------
2107 -- Processing_Actions --
2108 ------------------------
2110 procedure Processing_Actions
2111 (Has_No_Init : Boolean := False;
2112 Is_Protected : Boolean := False)
2115 -- Library-level tagged type
2117 if Nkind (Decl) = N_Full_Type_Declaration then
2119 Has_Tagged_Types := True;
2121 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2122 Last_Top_Level_Ctrl_Construct := Decl;
2126 Process_Tagged_Type_Declaration (Decl);
2129 -- Controlled object declaration
2133 Counter_Val := Counter_Val + 1;
2134 Has_Ctrl_Objs := True;
2136 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2137 Last_Top_Level_Ctrl_Construct := Decl;
2141 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2144 end Processing_Actions;
2146 -- Start of processing for Process_Declarations
2149 if No (Decls) or else Is_Empty_List (Decls) then
2153 -- Process all declarations in reverse order
2155 Decl := Last_Non_Pragma (Decls);
2156 while Present (Decl) loop
2158 -- Library-level tagged types
2160 if Nkind (Decl) = N_Full_Type_Declaration then
2161 Typ := Defining_Identifier (Decl);
2163 -- Ignored Ghost types do not need any cleanup actions because
2164 -- they will not appear in the final tree.
2166 if Is_Ignored_Ghost_Entity (Typ) then
2169 elsif Is_Tagged_Type (Typ)
2170 and then Is_Library_Level_Entity (Typ)
2171 and then Convention (Typ) = Convention_Ada
2172 and then Present (Access_Disp_Table (Typ))
2173 and then RTE_Available (RE_Register_Tag)
2174 and then not Is_Abstract_Type (Typ)
2175 and then not No_Run_Time_Mode
2180 -- Regular object declarations
2182 elsif Nkind (Decl) = N_Object_Declaration then
2183 Obj_Id := Defining_Identifier (Decl);
2184 Obj_Typ := Base_Type (Etype (Obj_Id));
2185 Expr := Expression (Decl);
2187 -- Bypass any form of processing for objects which have their
2188 -- finalization disabled. This applies only to objects at the
2191 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2194 -- Finalization of transient objects are treated separately in
2195 -- order to handle sensitive cases. These include:
2197 -- * Aggregate expansion
2198 -- * If, case, and expression with actions expansion
2199 -- * Transient scopes
2201 -- If one of those contexts has marked the transient object as
2202 -- ignored, do not generate finalization actions for it.
2204 elsif Is_Finalized_Transient (Obj_Id)
2205 or else Is_Ignored_Transient (Obj_Id)
2209 -- Ignored Ghost objects do not need any cleanup actions
2210 -- because they will not appear in the final tree.
2212 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2215 -- The object is of the form:
2216 -- Obj : [constant] Typ [:= Expr];
2218 -- Do not process tag-to-class-wide conversions because they do
2219 -- not yield an object. Do not process the incomplete view of a
2220 -- deferred constant. Note that an object initialized by means
2221 -- of a build-in-place function call may appear as a deferred
2222 -- constant after expansion activities. These kinds of objects
2223 -- must be finalized.
2225 elsif not Is_Imported (Obj_Id)
2226 and then Needs_Finalization (Obj_Typ)
2227 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
2228 and then not (Ekind (Obj_Id) = E_Constant
2229 and then not Has_Completion (Obj_Id)
2230 and then No (BIP_Initialization_Call (Obj_Id)))
2234 -- The object is of the form:
2235 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2237 -- Obj : Access_Typ :=
2238 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2240 elsif Is_Access_Type (Obj_Typ)
2241 and then Needs_Finalization
2242 (Available_View (Designated_Type (Obj_Typ)))
2243 and then Present (Expr)
2245 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2247 (Is_Non_BIP_Func_Call (Expr)
2248 and then not Is_Related_To_Func_Return (Obj_Id)))
2250 Processing_Actions (Has_No_Init => True);
2252 -- Processing for "hook" objects generated for transient
2253 -- objects declared inside an Expression_With_Actions.
2255 elsif Is_Access_Type (Obj_Typ)
2256 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2257 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2258 N_Object_Declaration
2260 Processing_Actions (Has_No_Init => True);
2262 -- Process intermediate results of an if expression with one
2263 -- of the alternatives using a controlled function call.
2265 elsif Is_Access_Type (Obj_Typ)
2266 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2267 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2268 N_Defining_Identifier
2269 and then Present (Expr)
2270 and then Nkind (Expr) = N_Null
2272 Processing_Actions (Has_No_Init => True);
2274 -- Simple protected objects which use type System.Tasking.
2275 -- Protected_Objects.Protection to manage their locks should
2276 -- be treated as controlled since they require manual cleanup.
2277 -- The only exception is illustrated in the following example:
2280 -- type Ctrl is new Controlled ...
2281 -- procedure Finalize (Obj : in out Ctrl);
2285 -- package body Pkg is
2286 -- protected Prot is
2287 -- procedure Do_Something (Obj : in out Ctrl);
2290 -- protected body Prot is
2291 -- procedure Do_Something (Obj : in out Ctrl) is ...
2294 -- procedure Finalize (Obj : in out Ctrl) is
2296 -- Prot.Do_Something (Obj);
2300 -- Since for the most part entities in package bodies depend on
2301 -- those in package specs, Prot's lock should be cleaned up
2302 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2303 -- This act however attempts to invoke Do_Something and fails
2304 -- because the lock has disappeared.
2306 elsif Ekind (Obj_Id) = E_Variable
2307 and then not In_Library_Level_Package_Body (Obj_Id)
2308 and then (Is_Simple_Protected_Type (Obj_Typ)
2309 or else Has_Simple_Protected_Object (Obj_Typ))
2311 Processing_Actions (Is_Protected => True);
2314 -- Specific cases of object renamings
2316 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2317 Obj_Id := Defining_Identifier (Decl);
2318 Obj_Typ := Base_Type (Etype (Obj_Id));
2320 -- Bypass any form of processing for objects which have their
2321 -- finalization disabled. This applies only to objects at the
2324 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2327 -- Ignored Ghost object renamings do not need any cleanup
2328 -- actions because they will not appear in the final tree.
2330 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2333 -- Return object of a build-in-place function. This case is
2334 -- recognized and marked by the expansion of an extended return
2335 -- statement (see Expand_N_Extended_Return_Statement).
2337 elsif Needs_Finalization (Obj_Typ)
2338 and then Is_Return_Object (Obj_Id)
2339 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2341 Processing_Actions (Has_No_Init => True);
2343 -- Detect a case where a source object has been initialized by
2344 -- a controlled function call or another object which was later
2345 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2347 -- Obj1 : CW_Type := Src_Obj;
2348 -- Obj2 : CW_Type := Function_Call (...);
2350 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2351 -- Tmp : ... := Function_Call (...)'reference;
2352 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2354 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
2355 Processing_Actions (Has_No_Init => True);
2358 -- Inspect the freeze node of an access-to-controlled type and
2359 -- look for a delayed finalization master. This case arises when
2360 -- the freeze actions are inserted at a later time than the
2361 -- expansion of the context. Since Build_Finalizer is never called
2362 -- on a single construct twice, the master will be ultimately
2363 -- left out and never finalized. This is also needed for freeze
2364 -- actions of designated types themselves, since in some cases the
2365 -- finalization master is associated with a designated type's
2366 -- freeze node rather than that of the access type (see handling
2367 -- for freeze actions in Build_Finalization_Master).
2369 elsif Nkind (Decl) = N_Freeze_Entity
2370 and then Present (Actions (Decl))
2372 Typ := Entity (Decl);
2374 -- Freeze nodes for ignored Ghost types do not need cleanup
2375 -- actions because they will never appear in the final tree.
2377 if Is_Ignored_Ghost_Entity (Typ) then
2380 elsif (Is_Access_Type (Typ)
2381 and then not Is_Access_Subprogram_Type (Typ)
2382 and then Needs_Finalization
2383 (Available_View (Designated_Type (Typ))))
2384 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2386 Old_Counter_Val := Counter_Val;
2388 -- Freeze nodes are considered to be identical to packages
2389 -- and blocks in terms of nesting. The difference is that
2390 -- a finalization master created inside the freeze node is
2391 -- at the same nesting level as the node itself.
2393 Process_Declarations (Actions (Decl), Preprocess);
2395 -- The freeze node contains a finalization master
2399 and then No (Last_Top_Level_Ctrl_Construct)
2400 and then Counter_Val > Old_Counter_Val
2402 Last_Top_Level_Ctrl_Construct := Decl;
2406 -- Nested package declarations, avoid generics
2408 elsif Nkind (Decl) = N_Package_Declaration then
2409 Pack_Id := Defining_Entity (Decl);
2410 Spec := Specification (Decl);
2412 -- Do not inspect an ignored Ghost package because all code
2413 -- found within will not appear in the final tree.
2415 if Is_Ignored_Ghost_Entity (Pack_Id) then
2418 elsif Ekind (Pack_Id) /= E_Generic_Package then
2419 Old_Counter_Val := Counter_Val;
2420 Process_Declarations
2421 (Private_Declarations (Spec), Preprocess);
2422 Process_Declarations
2423 (Visible_Declarations (Spec), Preprocess);
2425 -- Either the visible or the private declarations contain a
2426 -- controlled object. The nested package declaration is the
2427 -- last such construct.
2431 and then No (Last_Top_Level_Ctrl_Construct)
2432 and then Counter_Val > Old_Counter_Val
2434 Last_Top_Level_Ctrl_Construct := Decl;
2438 -- Nested package bodies, avoid generics
2440 elsif Nkind (Decl) = N_Package_Body then
2442 -- Do not inspect an ignored Ghost package body because all
2443 -- code found within will not appear in the final tree.
2445 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2448 elsif Ekind (Corresponding_Spec (Decl)) /=
2451 Old_Counter_Val := Counter_Val;
2452 Process_Declarations (Declarations (Decl), Preprocess);
2454 -- The nested package body is the last construct to contain
2455 -- a controlled object.
2459 and then No (Last_Top_Level_Ctrl_Construct)
2460 and then Counter_Val > Old_Counter_Val
2462 Last_Top_Level_Ctrl_Construct := Decl;
2466 -- Handle a rare case caused by a controlled transient object
2467 -- created as part of a record init proc. The variable is wrapped
2468 -- in a block, but the block is not associated with a transient
2471 elsif Nkind (Decl) = N_Block_Statement
2472 and then Inside_Init_Proc
2474 Old_Counter_Val := Counter_Val;
2476 if Present (Handled_Statement_Sequence (Decl)) then
2477 Process_Declarations
2478 (Statements (Handled_Statement_Sequence (Decl)),
2482 Process_Declarations (Declarations (Decl), Preprocess);
2484 -- Either the declaration or statement list of the block has a
2485 -- controlled object.
2489 and then No (Last_Top_Level_Ctrl_Construct)
2490 and then Counter_Val > Old_Counter_Val
2492 Last_Top_Level_Ctrl_Construct := Decl;
2495 -- Handle the case where the original context has been wrapped in
2496 -- a block to avoid interference between exception handlers and
2497 -- At_End handlers. Treat the block as transparent and process its
2500 elsif Nkind (Decl) = N_Block_Statement
2501 and then Is_Finalization_Wrapper (Decl)
2503 if Present (Handled_Statement_Sequence (Decl)) then
2504 Process_Declarations
2505 (Statements (Handled_Statement_Sequence (Decl)),
2509 Process_Declarations (Declarations (Decl), Preprocess);
2512 Prev_Non_Pragma (Decl);
2514 end Process_Declarations;
2516 --------------------------------
2517 -- Process_Object_Declaration --
2518 --------------------------------
2520 procedure Process_Object_Declaration
2522 Has_No_Init : Boolean := False;
2523 Is_Protected : Boolean := False)
2525 Loc : constant Source_Ptr := Sloc (Decl);
2526 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2528 Init_Typ : Entity_Id;
2529 -- The initialization type of the related object declaration. Note
2530 -- that this is not necessarily the same type as Obj_Typ because of
2531 -- possible type derivations.
2533 Obj_Typ : Entity_Id;
2534 -- The type of the related object declaration
2536 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2537 -- Func_Id denotes a build-in-place function. Generate the following
2540 -- if BIPallocfrom > Secondary_Stack'Pos
2541 -- and then BIPfinalizationmaster /= null
2544 -- type Ptr_Typ is access Obj_Typ;
2545 -- for Ptr_Typ'Storage_Pool
2546 -- use Base_Pool (BIPfinalizationmaster);
2548 -- Free (Ptr_Typ (Temp));
2552 -- Obj_Typ is the type of the current object, Temp is the original
2553 -- allocation which Obj_Id renames.
2555 procedure Find_Last_Init
2556 (Last_Init : out Node_Id;
2557 Body_Insert : out Node_Id);
2558 -- Find the last initialization call related to object declaration
2559 -- Decl. Last_Init denotes the last initialization call which follows
2560 -- Decl. Body_Insert denotes a node where the finalizer body could be
2561 -- potentially inserted after (if blocks are involved).
2563 -----------------------------
2564 -- Build_BIP_Cleanup_Stmts --
2565 -----------------------------
2567 function Build_BIP_Cleanup_Stmts
2568 (Func_Id : Entity_Id) return Node_Id
2570 Decls : constant List_Id := New_List;
2571 Fin_Mas_Id : constant Entity_Id :=
2572 Build_In_Place_Formal
2573 (Func_Id, BIP_Finalization_Master);
2574 Func_Typ : constant Entity_Id := Etype (Func_Id);
2575 Temp_Id : constant Entity_Id :=
2576 Entity (Prefix (Name (Parent (Obj_Id))));
2580 Free_Stmt : Node_Id;
2581 Pool_Id : Entity_Id;
2582 Ptr_Typ : Entity_Id;
2586 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2588 Pool_Id := Make_Temporary (Loc, 'P');
2591 Make_Object_Renaming_Declaration (Loc,
2592 Defining_Identifier => Pool_Id,
2594 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2596 Make_Explicit_Dereference (Loc,
2598 Make_Function_Call (Loc,
2600 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2601 Parameter_Associations => New_List (
2602 Make_Explicit_Dereference (Loc,
2604 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2606 -- Create an access type which uses the storage pool of the
2607 -- caller's finalization master.
2610 -- type Ptr_Typ is access Func_Typ;
2612 Ptr_Typ := Make_Temporary (Loc, 'P');
2615 Make_Full_Type_Declaration (Loc,
2616 Defining_Identifier => Ptr_Typ,
2618 Make_Access_To_Object_Definition (Loc,
2619 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2621 -- Perform minor decoration in order to set the master and the
2622 -- storage pool attributes.
2624 Set_Ekind (Ptr_Typ, E_Access_Type);
2625 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2626 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2628 -- Create an explicit free statement. Note that the free uses the
2629 -- caller's pool expressed as a renaming.
2632 Make_Free_Statement (Loc,
2634 Unchecked_Convert_To (Ptr_Typ,
2635 New_Occurrence_Of (Temp_Id, Loc)));
2637 Set_Storage_Pool (Free_Stmt, Pool_Id);
2639 -- Create a block to house the dummy type and the instantiation as
2640 -- well as to perform the cleanup the temporary.
2646 -- Free (Ptr_Typ (Temp_Id));
2650 Make_Block_Statement (Loc,
2651 Declarations => Decls,
2652 Handled_Statement_Sequence =>
2653 Make_Handled_Sequence_Of_Statements (Loc,
2654 Statements => New_List (Free_Stmt)));
2657 -- if BIPfinalizationmaster /= null then
2661 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2662 Right_Opnd => Make_Null (Loc));
2664 -- For constrained or tagged results escalate the condition to
2665 -- include the allocation format. Generate:
2667 -- if BIPallocform > Secondary_Stack'Pos
2668 -- and then BIPfinalizationmaster /= null
2671 if not Is_Constrained (Func_Typ)
2672 or else Is_Tagged_Type (Func_Typ)
2675 Alloc : constant Entity_Id :=
2676 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2682 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2684 Make_Integer_Literal (Loc,
2686 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2688 Right_Opnd => Cond);
2698 Make_If_Statement (Loc,
2700 Then_Statements => New_List (Free_Blk));
2701 end Build_BIP_Cleanup_Stmts;
2703 --------------------
2704 -- Find_Last_Init --
2705 --------------------
2707 procedure Find_Last_Init
2708 (Last_Init : out Node_Id;
2709 Body_Insert : out Node_Id)
2711 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2712 -- Find the last initialization call within the statements of
2715 function Is_Init_Call (N : Node_Id) return Boolean;
2716 -- Determine whether node N denotes one of the initialization
2717 -- procedures of types Init_Typ or Obj_Typ.
2719 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2720 -- Obtain the next statement which follows list member Stmt while
2721 -- ignoring artifacts related to access-before-elaboration checks.
2723 -----------------------------
2724 -- Find_Last_Init_In_Block --
2725 -----------------------------
2727 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2728 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2732 -- Examine the individual statements of the block in reverse to
2733 -- locate the last initialization call.
2735 if Present (HSS) and then Present (Statements (HSS)) then
2736 Stmt := Last (Statements (HSS));
2737 while Present (Stmt) loop
2739 -- Peek inside nested blocks in case aborts are allowed
2741 if Nkind (Stmt) = N_Block_Statement then
2742 return Find_Last_Init_In_Block (Stmt);
2744 elsif Is_Init_Call (Stmt) then
2753 end Find_Last_Init_In_Block;
2759 function Is_Init_Call (N : Node_Id) return Boolean is
2760 function Is_Init_Proc_Of
2761 (Subp_Id : Entity_Id;
2762 Typ : Entity_Id) return Boolean;
2763 -- Determine whether subprogram Subp_Id is a valid init proc of
2766 ---------------------
2767 -- Is_Init_Proc_Of --
2768 ---------------------
2770 function Is_Init_Proc_Of
2771 (Subp_Id : Entity_Id;
2772 Typ : Entity_Id) return Boolean
2774 Deep_Init : Entity_Id := Empty;
2775 Prim_Init : Entity_Id := Empty;
2776 Type_Init : Entity_Id := Empty;
2779 -- Obtain all possible initialization routines of the
2780 -- related type and try to match the subprogram entity
2781 -- against one of them.
2785 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2787 -- Primitive Initialize
2789 if Is_Controlled (Typ) then
2790 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2792 if Present (Prim_Init) then
2793 Prim_Init := Ultimate_Alias (Prim_Init);
2797 -- Type initialization routine
2799 if Has_Non_Null_Base_Init_Proc (Typ) then
2800 Type_Init := Base_Init_Proc (Typ);
2804 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2806 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2808 (Present (Type_Init) and then Subp_Id = Type_Init);
2809 end Is_Init_Proc_Of;
2813 Call_Id : Entity_Id;
2815 -- Start of processing for Is_Init_Call
2818 if Nkind (N) = N_Procedure_Call_Statement
2819 and then Nkind (Name (N)) = N_Identifier
2821 Call_Id := Entity (Name (N));
2823 -- Consider both the type of the object declaration and its
2824 -- related initialization type.
2827 Is_Init_Proc_Of (Call_Id, Init_Typ)
2829 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2835 -----------------------------
2836 -- Next_Suitable_Statement --
2837 -----------------------------
2839 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2843 -- Skip call markers and Program_Error raises installed by the
2846 Result := Next (Stmt);
2847 while Present (Result) loop
2848 if not Nkind_In (Result, N_Call_Marker,
2849 N_Raise_Program_Error)
2854 Result := Next (Result);
2858 end Next_Suitable_Statement;
2866 Deep_Init_Found : Boolean := False;
2867 -- A flag set when a call to [Deep_]Initialize has been found
2869 -- Start of processing for Find_Last_Init
2873 Body_Insert := Empty;
2875 -- Object renamings and objects associated with controlled
2876 -- function results do not require initialization.
2882 Stmt := Next_Suitable_Statement (Decl);
2884 -- For an object with suppressed initialization, we check whether
2885 -- there is in fact no initialization expression. If there is not,
2886 -- then this is an object declaration that has been turned into a
2887 -- different object declaration that calls the build-in-place
2888 -- function in a 'Reference attribute, as in "F(...)'Reference".
2889 -- We search for that later object declaration, so that the
2890 -- Inc_Decl will be inserted after the call. Otherwise, if the
2891 -- call raises an exception, we will finalize the (uninitialized)
2892 -- object, which is wrong.
2894 if No_Initialization (Decl) then
2895 if No (Expression (Last_Init)) then
2897 Last_Init := Next (Last_Init);
2898 exit when No (Last_Init);
2899 exit when Nkind (Last_Init) = N_Object_Declaration
2900 and then Nkind (Expression (Last_Init)) = N_Reference
2901 and then Nkind (Prefix (Expression (Last_Init))) =
2903 and then Is_Expanded_Build_In_Place_Call
2904 (Prefix (Expression (Last_Init)));
2910 -- In all other cases the initialization calls follow the related
2911 -- object. The general structure of object initialization built by
2912 -- routine Default_Initialize_Object is as follows:
2914 -- [begin -- aborts allowed
2916 -- Type_Init_Proc (Obj);
2917 -- [begin] -- exceptions allowed
2918 -- Deep_Initialize (Obj);
2919 -- [exception -- exceptions allowed
2921 -- Deep_Finalize (Obj, Self => False);
2924 -- [at end -- aborts allowed
2928 -- When aborts are allowed, the initialization calls are housed
2931 elsif Nkind (Stmt) = N_Block_Statement then
2932 Last_Init := Find_Last_Init_In_Block (Stmt);
2933 Body_Insert := Stmt;
2935 -- Otherwise the initialization calls follow the related object
2938 Stmt_2 := Next_Suitable_Statement (Stmt);
2940 -- Check for an optional call to Deep_Initialize which may
2941 -- appear within a block depending on whether the object has
2942 -- controlled components.
2944 if Present (Stmt_2) then
2945 if Nkind (Stmt_2) = N_Block_Statement then
2946 Call := Find_Last_Init_In_Block (Stmt_2);
2948 if Present (Call) then
2949 Deep_Init_Found := True;
2951 Body_Insert := Stmt_2;
2954 elsif Is_Init_Call (Stmt_2) then
2955 Deep_Init_Found := True;
2956 Last_Init := Stmt_2;
2957 Body_Insert := Last_Init;
2961 -- If the object lacks a call to Deep_Initialize, then it must
2962 -- have a call to its related type init proc.
2964 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
2966 Body_Insert := Last_Init;
2974 Count_Ins : Node_Id;
2976 Fin_Stmts : List_Id := No_List;
2979 Label_Id : Entity_Id;
2982 -- Start of processing for Process_Object_Declaration
2985 -- Handle the object type and the reference to the object
2987 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2988 Obj_Typ := Base_Type (Etype (Obj_Id));
2991 if Is_Access_Type (Obj_Typ) then
2992 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2993 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2995 elsif Is_Concurrent_Type (Obj_Typ)
2996 and then Present (Corresponding_Record_Type (Obj_Typ))
2998 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
2999 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3001 elsif Is_Private_Type (Obj_Typ)
3002 and then Present (Full_View (Obj_Typ))
3004 Obj_Typ := Full_View (Obj_Typ);
3005 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3007 elsif Obj_Typ /= Base_Type (Obj_Typ) then
3008 Obj_Typ := Base_Type (Obj_Typ);
3009 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3016 Set_Etype (Obj_Ref, Obj_Typ);
3018 -- Handle the initialization type of the object declaration
3020 Init_Typ := Obj_Typ;
3022 if Is_Private_Type (Init_Typ)
3023 and then Present (Full_View (Init_Typ))
3025 Init_Typ := Full_View (Init_Typ);
3027 elsif Is_Untagged_Derivation (Init_Typ) then
3028 Init_Typ := Root_Type (Init_Typ);
3035 -- Set a new value for the state counter and insert the statement
3036 -- after the object declaration. Generate:
3038 -- Counter := <value>;
3041 Make_Assignment_Statement (Loc,
3042 Name => New_Occurrence_Of (Counter_Id, Loc),
3043 Expression => Make_Integer_Literal (Loc, Counter_Val));
3045 -- Insert the counter after all initialization has been done. The
3046 -- place of insertion depends on the context.
3048 if Ekind_In (Obj_Id, E_Constant, E_Variable) then
3050 -- The object is initialized by a build-in-place function call.
3051 -- The counter insertion point is after the function call.
3053 if Present (BIP_Initialization_Call (Obj_Id)) then
3054 Count_Ins := BIP_Initialization_Call (Obj_Id);
3057 -- The object is initialized by an aggregate. Insert the counter
3058 -- after the last aggregate assignment.
3060 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
3061 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
3064 -- In all other cases the counter is inserted after the last call
3065 -- to either [Deep_]Initialize or the type-specific init proc.
3068 Find_Last_Init (Count_Ins, Body_Ins);
3071 -- In all other cases the counter is inserted after the last call to
3072 -- either [Deep_]Initialize or the type-specific init proc.
3075 Find_Last_Init (Count_Ins, Body_Ins);
3078 -- If the Initialize function is null or trivial, the call will have
3079 -- been replaced with a null statement, in which case place counter
3080 -- declaration after object declaration itself.
3082 if No (Count_Ins) then
3086 Insert_After (Count_Ins, Inc_Decl);
3089 -- If the current declaration is the last in the list, the finalizer
3090 -- body needs to be inserted after the set counter statement for the
3091 -- current object declaration. This is complicated by the fact that
3092 -- the set counter statement may appear in abort deferred block. In
3093 -- that case, the proper insertion place is after the block.
3095 if No (Finalizer_Insert_Nod) then
3097 -- Insertion after an abort deferred block
3099 if Present (Body_Ins) then
3100 Finalizer_Insert_Nod := Body_Ins;
3102 Finalizer_Insert_Nod := Inc_Decl;
3106 -- Create the associated label with this object, generate:
3108 -- L<counter> : label;
3111 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
3113 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
3114 Label := Make_Label (Loc, Label_Id);
3116 Prepend_To (Finalizer_Decls,
3117 Make_Implicit_Label_Declaration (Loc,
3118 Defining_Identifier => Entity (Label_Id),
3119 Label_Construct => Label));
3121 -- Create the associated jump with this object, generate:
3123 -- when <counter> =>
3126 Prepend_To (Jump_Alts,
3127 Make_Case_Statement_Alternative (Loc,
3128 Discrete_Choices => New_List (
3129 Make_Integer_Literal (Loc, Counter_Val)),
3130 Statements => New_List (
3131 Make_Goto_Statement (Loc,
3132 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
3134 -- Insert the jump destination, generate:
3138 Append_To (Finalizer_Stmts, Label);
3140 -- Processing for simple protected objects. Such objects require
3141 -- manual finalization of their lock managers.
3143 if Is_Protected then
3144 if Is_Simple_Protected_Type (Obj_Typ) then
3145 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3147 if Present (Fin_Call) then
3148 Fin_Stmts := New_List (Fin_Call);
3151 elsif Has_Simple_Protected_Object (Obj_Typ) then
3152 if Is_Record_Type (Obj_Typ) then
3153 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3154 elsif Is_Array_Type (Obj_Typ) then
3155 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3161 -- System.Tasking.Protected_Objects.Finalize_Protection
3169 if Present (Fin_Stmts) and then Exceptions_OK then
3170 Fin_Stmts := New_List (
3171 Make_Block_Statement (Loc,
3172 Handled_Statement_Sequence =>
3173 Make_Handled_Sequence_Of_Statements (Loc,
3174 Statements => Fin_Stmts,
3176 Exception_Handlers => New_List (
3177 Make_Exception_Handler (Loc,
3178 Exception_Choices => New_List (
3179 Make_Others_Choice (Loc)),
3181 Statements => New_List (
3182 Make_Null_Statement (Loc)))))));
3185 -- Processing for regular controlled objects
3190 -- [Deep_]Finalize (Obj);
3193 -- when Id : others =>
3194 -- if not Raised then
3196 -- Save_Occurrence (E, Id);
3205 -- Guard against a missing [Deep_]Finalize when the object type
3206 -- was not properly frozen.
3208 if No (Fin_Call) then
3209 Fin_Call := Make_Null_Statement (Loc);
3212 -- For CodePeer, the exception handlers normally generated here
3213 -- generate complex flowgraphs which result in capacity problems.
3214 -- Omitting these handlers for CodePeer is justified as follows:
3216 -- If a handler is dead, then omitting it is surely ok
3218 -- If a handler is live, then CodePeer should flag the
3219 -- potentially-exception-raising construct that causes it
3220 -- to be live. That is what we are interested in, not what
3221 -- happens after the exception is raised.
3223 if Exceptions_OK and not CodePeer_Mode then
3224 Fin_Stmts := New_List (
3225 Make_Block_Statement (Loc,
3226 Handled_Statement_Sequence =>
3227 Make_Handled_Sequence_Of_Statements (Loc,
3228 Statements => New_List (Fin_Call),
3230 Exception_Handlers => New_List (
3231 Build_Exception_Handler
3232 (Finalizer_Data, For_Package)))));
3234 -- When exception handlers are prohibited, the finalization call
3235 -- appears unprotected. Any exception raised during finalization
3236 -- will bypass the circuitry which ensures the cleanup of all
3237 -- remaining objects.
3240 Fin_Stmts := New_List (Fin_Call);
3243 -- If we are dealing with a return object of a build-in-place
3244 -- function, generate the following cleanup statements:
3246 -- if BIPallocfrom > Secondary_Stack'Pos
3247 -- and then BIPfinalizationmaster /= null
3250 -- type Ptr_Typ is access Obj_Typ;
3251 -- for Ptr_Typ'Storage_Pool use
3252 -- Base_Pool (BIPfinalizationmaster.all).all;
3254 -- Free (Ptr_Typ (Temp));
3258 -- The generated code effectively detaches the temporary from the
3259 -- caller finalization master and deallocates the object.
3261 if Is_Return_Object (Obj_Id) then
3263 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
3265 if Is_Build_In_Place_Function (Func_Id)
3266 and then Needs_BIP_Finalization_Master (Func_Id)
3268 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3273 if Ekind_In (Obj_Id, E_Constant, E_Variable)
3274 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3276 -- Temporaries created for the purpose of "exporting" a
3277 -- transient object out of an Expression_With_Actions (EWA)
3278 -- need guards. The following illustrates the usage of such
3281 -- Access_Typ : access [all] Obj_Typ;
3282 -- Temp : Access_Typ := null;
3283 -- <Counter> := ...;
3286 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3287 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3289 -- Temp := Ctrl_Trans'Unchecked_Access;
3292 -- The finalization machinery does not process EWA nodes as
3293 -- this may lead to premature finalization of expressions. Note
3294 -- that Temp is marked as being properly initialized regardless
3295 -- of whether the initialization of Ctrl_Trans succeeded. Since
3296 -- a failed initialization may leave Temp with a value of null,
3297 -- add a guard to handle this case:
3299 -- if Obj /= null then
3300 -- <object finalization statements>
3303 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3304 N_Object_Declaration
3306 Fin_Stmts := New_List (
3307 Make_If_Statement (Loc,
3310 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3311 Right_Opnd => Make_Null (Loc)),
3312 Then_Statements => Fin_Stmts));
3314 -- Return objects use a flag to aid in processing their
3315 -- potential finalization when the enclosing function fails
3316 -- to return properly. Generate:
3319 -- <object finalization statements>
3323 Fin_Stmts := New_List (
3324 Make_If_Statement (Loc,
3329 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3331 Then_Statements => Fin_Stmts));
3336 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3338 -- Since the declarations are examined in reverse, the state counter
3339 -- must be decremented in order to keep with the true position of
3342 Counter_Val := Counter_Val - 1;
3343 end Process_Object_Declaration;
3345 -------------------------------------
3346 -- Process_Tagged_Type_Declaration --
3347 -------------------------------------
3349 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3350 Typ : constant Entity_Id := Defining_Identifier (Decl);
3351 DT_Ptr : constant Entity_Id :=
3352 Node (First_Elmt (Access_Disp_Table (Typ)));
3355 -- Ada.Tags.Unregister_Tag (<Typ>P);
3357 Append_To (Tagged_Type_Stmts,
3358 Make_Procedure_Call_Statement (Loc,
3360 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3361 Parameter_Associations => New_List (
3362 New_Occurrence_Of (DT_Ptr, Loc))));
3363 end Process_Tagged_Type_Declaration;
3365 -- Start of processing for Build_Finalizer
3370 -- Do not perform this expansion in SPARK mode because it is not
3373 if GNATprove_Mode then
3377 -- Step 1: Extract all lists which may contain controlled objects or
3378 -- library-level tagged types.
3380 if For_Package_Spec then
3381 Decls := Visible_Declarations (Specification (N));
3382 Priv_Decls := Private_Declarations (Specification (N));
3384 -- Retrieve the package spec id
3386 Spec_Id := Defining_Unit_Name (Specification (N));
3388 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3389 Spec_Id := Defining_Identifier (Spec_Id);
3392 -- Accept statement, block, entry body, package body, protected body,
3393 -- subprogram body or task body.
3396 Decls := Declarations (N);
3397 HSS := Handled_Statement_Sequence (N);
3399 if Present (HSS) then
3400 if Present (Statements (HSS)) then
3401 Stmts := Statements (HSS);
3404 if Present (At_End_Proc (HSS)) then
3405 Prev_At_End := At_End_Proc (HSS);
3409 -- Retrieve the package spec id for package bodies
3411 if For_Package_Body then
3412 Spec_Id := Corresponding_Spec (N);
3416 -- Do not process nested packages since those are handled by the
3417 -- enclosing scope's finalizer. Do not process non-expanded package
3418 -- instantiations since those will be re-analyzed and re-expanded.
3422 (not Is_Library_Level_Entity (Spec_Id)
3424 -- Nested packages are considered to be library level entities,
3425 -- but do not need to be processed separately. True library level
3426 -- packages have a scope value of 1.
3428 or else Scope_Depth_Value (Spec_Id) /= Uint_1
3429 or else (Is_Generic_Instance (Spec_Id)
3430 and then Package_Instantiation (Spec_Id) /= N))
3435 -- Step 2: Object [pre]processing
3439 -- Preprocess the visible declarations now in order to obtain the
3440 -- correct number of controlled object by the time the private
3441 -- declarations are processed.
3443 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3445 -- From all the possible contexts, only package specifications may
3446 -- have private declarations.
3448 if For_Package_Spec then
3449 Process_Declarations
3450 (Priv_Decls, Preprocess => True, Top_Level => True);
3453 -- The current context may lack controlled objects, but require some
3454 -- other form of completion (task termination for instance). In such
3455 -- cases, the finalizer must be created and carry the additional
3458 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3462 -- The preprocessing has determined that the context has controlled
3463 -- objects or library-level tagged types.
3465 if Has_Ctrl_Objs or Has_Tagged_Types then
3467 -- Private declarations are processed first in order to preserve
3468 -- possible dependencies between public and private objects.
3470 if For_Package_Spec then
3471 Process_Declarations (Priv_Decls);
3474 Process_Declarations (Decls);
3480 -- Preprocess both declarations and statements
3482 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3483 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3485 -- At this point it is known that N has controlled objects. Ensure
3486 -- that N has a declarative list since the finalizer spec will be
3489 if Has_Ctrl_Objs and then No (Decls) then
3490 Set_Declarations (N, New_List);
3491 Decls := Declarations (N);
3492 Spec_Decls := Decls;
3495 -- The current context may lack controlled objects, but require some
3496 -- other form of completion (task termination for instance). In such
3497 -- cases, the finalizer must be created and carry the additional
3500 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3504 if Has_Ctrl_Objs or Has_Tagged_Types then
3505 Process_Declarations (Stmts);
3506 Process_Declarations (Decls);
3510 -- Step 3: Finalizer creation
3512 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3515 end Build_Finalizer;
3517 --------------------------
3518 -- Build_Finalizer_Call --
3519 --------------------------
3521 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3522 Is_Prot_Body : constant Boolean :=
3523 Nkind (N) = N_Subprogram_Body
3524 and then Is_Protected_Subprogram_Body (N);
3525 -- Determine whether N denotes the protected version of a subprogram
3526 -- which belongs to a protected type.
3528 Loc : constant Source_Ptr := Sloc (N);
3532 -- Do not perform this expansion in SPARK mode because we do not create
3533 -- finalizers in the first place.
3535 if GNATprove_Mode then
3539 -- The At_End handler should have been assimilated by the finalizer
3541 HSS := Handled_Statement_Sequence (N);
3542 pragma Assert (No (At_End_Proc (HSS)));
3544 -- If the construct to be cleaned up is a protected subprogram body, the
3545 -- finalizer call needs to be associated with the block which wraps the
3546 -- unprotected version of the subprogram. The following illustrates this
3549 -- procedure Prot_SubpP is
3550 -- procedure finalizer is
3552 -- Service_Entries (Prot_Obj);
3559 -- Prot_SubpN (Prot_Obj);
3565 if Is_Prot_Body then
3566 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3568 -- An At_End handler and regular exception handlers cannot coexist in
3569 -- the same statement sequence. Wrap the original statements in a block.
3571 elsif Present (Exception_Handlers (HSS)) then
3573 End_Lab : constant Node_Id := End_Label (HSS);
3578 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3580 Set_Handled_Statement_Sequence (N,
3581 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3583 HSS := Handled_Statement_Sequence (N);
3584 Set_End_Label (HSS, End_Lab);
3588 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3590 -- Attach reference to finalizer to tree, for LLVM use
3592 Set_Parent (At_End_Proc (HSS), HSS);
3594 Analyze (At_End_Proc (HSS));
3595 Expand_At_End_Handler (HSS, Empty);
3596 end Build_Finalizer_Call;
3598 ---------------------
3599 -- Build_Late_Proc --
3600 ---------------------
3602 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3604 for Final_Prim in Name_Of'Range loop
3605 if Name_Of (Final_Prim) = Nam then
3608 (Prim => Final_Prim,
3610 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3613 end Build_Late_Proc;
3615 -------------------------------
3616 -- Build_Object_Declarations --
3617 -------------------------------
3619 procedure Build_Object_Declarations
3620 (Data : out Finalization_Exception_Data;
3623 For_Package : Boolean := False)
3628 -- This variable captures an unused dummy internal entity, see the
3629 -- comment associated with its use.
3632 pragma Assert (Decls /= No_List);
3634 -- Always set the proper location as it may be needed even when
3635 -- exception propagation is forbidden.
3639 if Restriction_Active (No_Exception_Propagation) then
3640 Data.Abort_Id := Empty;
3642 Data.Raised_Id := Empty;
3646 Data.Raised_Id := Make_Temporary (Loc, 'R');
3648 -- In certain scenarios, finalization can be triggered by an abort. If
3649 -- the finalization itself fails and raises an exception, the resulting
3650 -- Program_Error must be supressed and replaced by an abort signal. In
3651 -- order to detect this scenario, save the state of entry into the
3652 -- finalization code.
3654 -- This is not needed for library-level finalizers as they are called by
3655 -- the environment task and cannot be aborted.
3657 if not For_Package then
3658 if Abort_Allowed then
3659 Data.Abort_Id := Make_Temporary (Loc, 'A');
3662 -- Abort_Id : constant Boolean := <A_Expr>;
3665 Make_Object_Declaration (Loc,
3666 Defining_Identifier => Data.Abort_Id,
3667 Constant_Present => True,
3668 Object_Definition =>
3669 New_Occurrence_Of (Standard_Boolean, Loc),
3671 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3673 -- Abort is not required
3676 -- Generate a dummy entity to ensure that the internal symbols are
3677 -- in sync when a unit is compiled with and without aborts.
3679 Dummy := Make_Temporary (Loc, 'A');
3680 Data.Abort_Id := Empty;
3683 -- Library-level finalizers
3686 Data.Abort_Id := Empty;
3689 if Exception_Extra_Info then
3690 Data.E_Id := Make_Temporary (Loc, 'E');
3693 -- E_Id : Exception_Occurrence;
3696 Make_Object_Declaration (Loc,
3697 Defining_Identifier => Data.E_Id,
3698 Object_Definition =>
3699 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3700 Set_No_Initialization (Decl);
3702 Append_To (Decls, Decl);
3709 -- Raised_Id : Boolean := False;
3712 Make_Object_Declaration (Loc,
3713 Defining_Identifier => Data.Raised_Id,
3714 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3715 Expression => New_Occurrence_Of (Standard_False, Loc)));
3716 end Build_Object_Declarations;
3718 ---------------------------
3719 -- Build_Raise_Statement --
3720 ---------------------------
3722 function Build_Raise_Statement
3723 (Data : Finalization_Exception_Data) return Node_Id
3729 -- Standard run-time use the specialized routine
3730 -- Raise_From_Controlled_Operation.
3732 if Exception_Extra_Info
3733 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3736 Make_Procedure_Call_Statement (Data.Loc,
3739 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3740 Parameter_Associations =>
3741 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3743 -- Restricted run-time: exception messages are not supported and hence
3744 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3749 Make_Raise_Program_Error (Data.Loc,
3750 Reason => PE_Finalize_Raised_Exception);
3755 -- Raised_Id and then not Abort_Id
3759 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3761 if Present (Data.Abort_Id) then
3762 Expr := Make_And_Then (Data.Loc,
3765 Make_Op_Not (Data.Loc,
3766 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3771 -- if Raised_Id and then not Abort_Id then
3772 -- Raise_From_Controlled_Operation (E_Id);
3774 -- raise Program_Error; -- restricted runtime
3778 Make_If_Statement (Data.Loc,
3780 Then_Statements => New_List (Stmt));
3781 end Build_Raise_Statement;
3783 -----------------------------
3784 -- Build_Record_Deep_Procs --
3785 -----------------------------
3787 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3791 (Prim => Initialize_Case,
3793 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3795 if not Is_Limited_View (Typ) then
3798 (Prim => Adjust_Case,
3800 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3803 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3804 -- suppressed since these routine will not be used.
3806 if not Restriction_Active (No_Finalization) then
3809 (Prim => Finalize_Case,
3811 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3813 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3815 if not CodePeer_Mode then
3818 (Prim => Address_Case,
3820 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3823 end Build_Record_Deep_Procs;
3829 function Cleanup_Array
3832 Typ : Entity_Id) return List_Id
3834 Loc : constant Source_Ptr := Sloc (N);
3835 Index_List : constant List_Id := New_List;
3837 function Free_Component return List_Id;
3838 -- Generate the code to finalize the task or protected subcomponents
3839 -- of a single component of the array.
3841 function Free_One_Dimension (Dim : Int) return List_Id;
3842 -- Generate a loop over one dimension of the array
3844 --------------------
3845 -- Free_Component --
3846 --------------------
3848 function Free_Component return List_Id is
3849 Stmts : List_Id := New_List;
3851 C_Typ : constant Entity_Id := Component_Type (Typ);
3854 -- Component type is known to contain tasks or protected objects
3857 Make_Indexed_Component (Loc,
3858 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3859 Expressions => Index_List);
3861 Set_Etype (Tsk, C_Typ);
3863 if Is_Task_Type (C_Typ) then
3864 Append_To (Stmts, Cleanup_Task (N, Tsk));
3866 elsif Is_Simple_Protected_Type (C_Typ) then
3867 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3869 elsif Is_Record_Type (C_Typ) then
3870 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3872 elsif Is_Array_Type (C_Typ) then
3873 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3879 ------------------------
3880 -- Free_One_Dimension --
3881 ------------------------
3883 function Free_One_Dimension (Dim : Int) return List_Id is
3887 if Dim > Number_Dimensions (Typ) then
3888 return Free_Component;
3890 -- Here we generate the required loop
3893 Index := Make_Temporary (Loc, 'J');
3894 Append (New_Occurrence_Of (Index, Loc), Index_List);
3897 Make_Implicit_Loop_Statement (N,
3898 Identifier => Empty,
3900 Make_Iteration_Scheme (Loc,
3901 Loop_Parameter_Specification =>
3902 Make_Loop_Parameter_Specification (Loc,
3903 Defining_Identifier => Index,
3904 Discrete_Subtype_Definition =>
3905 Make_Attribute_Reference (Loc,
3906 Prefix => Duplicate_Subexpr (Obj),
3907 Attribute_Name => Name_Range,
3908 Expressions => New_List (
3909 Make_Integer_Literal (Loc, Dim))))),
3910 Statements => Free_One_Dimension (Dim + 1)));
3912 end Free_One_Dimension;
3914 -- Start of processing for Cleanup_Array
3917 return Free_One_Dimension (1);
3920 --------------------
3921 -- Cleanup_Record --
3922 --------------------
3924 function Cleanup_Record
3927 Typ : Entity_Id) return List_Id
3929 Loc : constant Source_Ptr := Sloc (N);
3930 Stmts : constant List_Id := New_List;
3931 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3937 if Has_Discriminants (U_Typ)
3938 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3939 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3942 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3944 -- For now, do not attempt to free a component that may appear in a
3945 -- variant, and instead issue a warning. Doing this "properly" would
3946 -- require building a case statement and would be quite a mess. Note
3947 -- that the RM only requires that free "work" for the case of a task
3948 -- access value, so already we go way beyond this in that we deal
3949 -- with the array case and non-discriminated record cases.
3952 ("task/protected object in variant record will not be freed??", N);
3953 return New_List (Make_Null_Statement (Loc));
3956 Comp := First_Component (U_Typ);
3957 while Present (Comp) loop
3958 if Has_Task (Etype (Comp))
3959 or else Has_Simple_Protected_Object (Etype (Comp))
3962 Make_Selected_Component (Loc,
3963 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3964 Selector_Name => New_Occurrence_Of (Comp, Loc));
3965 Set_Etype (Tsk, Etype (Comp));
3967 if Is_Task_Type (Etype (Comp)) then
3968 Append_To (Stmts, Cleanup_Task (N, Tsk));
3970 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3971 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3973 elsif Is_Record_Type (Etype (Comp)) then
3975 -- Recurse, by generating the prefix of the argument to the
3976 -- eventual cleanup call.
3978 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3980 elsif Is_Array_Type (Etype (Comp)) then
3981 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3985 Next_Component (Comp);
3991 ------------------------------
3992 -- Cleanup_Protected_Object --
3993 ------------------------------
3995 function Cleanup_Protected_Object
3997 Ref : Node_Id) return Node_Id
3999 Loc : constant Source_Ptr := Sloc (N);
4002 -- For restricted run-time libraries (Ravenscar), tasks are
4003 -- non-terminating, and protected objects can only appear at library
4004 -- level, so we do not want finalization of protected objects.
4006 if Restricted_Profile then
4011 Make_Procedure_Call_Statement (Loc,
4013 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
4014 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4016 end Cleanup_Protected_Object;
4022 function Cleanup_Task
4024 Ref : Node_Id) return Node_Id
4026 Loc : constant Source_Ptr := Sloc (N);
4029 -- For restricted run-time libraries (Ravenscar), tasks are
4030 -- non-terminating and they can only appear at library level,
4031 -- so we do not want finalization of task objects.
4033 if Restricted_Profile then
4038 Make_Procedure_Call_Statement (Loc,
4040 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
4041 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4045 --------------------------------------
4046 -- Check_Unnesting_Elaboration_Code --
4047 --------------------------------------
4049 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
4050 Loc : constant Source_Ptr := Sloc (N);
4051 Block_Elab_Proc : Entity_Id := Empty;
4053 procedure Set_Block_Elab_Proc;
4054 -- Create a defining identifier for a procedure that will replace
4055 -- a block with nested subprograms (unless it has already been created,
4056 -- in which case this is a no-op).
4058 procedure Set_Block_Elab_Proc is
4060 if No (Block_Elab_Proc) then
4062 Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I'));
4064 end Set_Block_Elab_Proc;
4066 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
4067 -- Find entities in the elaboration code of a library package body that
4068 -- contain or represent a subprogram body. A body can appear within a
4069 -- block or a loop or can appear by itself if generated for an object
4070 -- declaration that involves controlled actions. The first such entity
4071 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4072 -- that will be used to reset the scopes of all entities that become
4073 -- local to the new elaboration procedure. This is needed for subsequent
4074 -- unnesting actions, which depend on proper setting of the Scope links
4075 -- to determine the nesting level of each subprogram.
4077 -----------------------
4078 -- Find_Local_Scope --
4079 -----------------------
4081 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
4087 while Present (Stat) loop
4088 case Nkind (Stat) is
4089 when N_Block_Statement =>
4090 Id := Entity (Identifier (Stat));
4092 -- The Scope of this block needs to be reset to the new
4093 -- procedure if the block contains nested subprograms.
4095 if Present (Id) and then Contains_Subprogram (Id) then
4096 Set_Block_Elab_Proc;
4097 Set_Scope (Id, Block_Elab_Proc);
4100 when N_Loop_Statement =>
4101 Id := Entity (Identifier (Stat));
4103 if Present (Id) and then Contains_Subprogram (Id) then
4104 if Scope (Id) = Current_Scope then
4105 Set_Block_Elab_Proc;
4106 Set_Scope (Id, Block_Elab_Proc);
4110 -- We traverse the loop's statements as well, which may
4111 -- include other block (etc.) statements that need to have
4112 -- their Scope set to Block_Elab_Proc. (Is this really the
4113 -- case, or do such nested blocks refer to the loop scope
4114 -- rather than the loop's enclosing scope???.)
4116 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
4118 when N_If_Statement =>
4119 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
4121 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
4127 Elif := First (Elsif_Parts (Stat));
4128 while Present (Elif) loop
4129 Reset_Scopes_To_Block_Elab_Proc
4130 (Then_Statements (Elif));
4136 when N_Case_Statement =>
4141 Alt := First (Alternatives (Stat));
4142 while Present (Alt) loop
4143 Reset_Scopes_To_Block_Elab_Proc (Statements (Alt));
4149 -- Reset the Scope of a subprogram occurring at the top level
4151 when N_Subprogram_Body =>
4152 Id := Defining_Entity (Stat);
4154 Set_Block_Elab_Proc;
4155 Set_Scope (Id, Block_Elab_Proc);
4163 end Reset_Scopes_To_Block_Elab_Proc;
4167 H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4168 Elab_Body : Node_Id;
4169 Elab_Call : Node_Id;
4171 -- Start of processing for Check_Unnesting_Elaboration_Code
4174 if Present (H_Seq) then
4175 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
4177 -- There may be subprograms declared in the exception handlers
4178 -- of the current body.
4180 if Present (Exception_Handlers (H_Seq)) then
4182 Handler : Node_Id := First (Exception_Handlers (H_Seq));
4184 while Present (Handler) loop
4185 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
4192 if Present (Block_Elab_Proc) then
4194 Make_Subprogram_Body (Loc,
4196 Make_Procedure_Specification (Loc,
4197 Defining_Unit_Name => Block_Elab_Proc),
4198 Declarations => New_List,
4199 Handled_Statement_Sequence =>
4200 Relocate_Node (Handled_Statement_Sequence (N)));
4203 Make_Procedure_Call_Statement (Loc,
4204 Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
4206 Append_To (Declarations (N), Elab_Body);
4207 Analyze (Elab_Body);
4208 Set_Has_Nested_Subprogram (Block_Elab_Proc);
4210 Set_Handled_Statement_Sequence (N,
4211 Make_Handled_Sequence_Of_Statements (Loc,
4212 Statements => New_List (Elab_Call)));
4214 Analyze (Elab_Call);
4216 -- Could we reset the scopes of entities associated with the new
4217 -- procedure here via a loop over entities rather than doing it in
4218 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4221 end Check_Unnesting_Elaboration_Code;
4223 ---------------------------------------
4224 -- Check_Unnesting_In_Decls_Or_Stmts --
4225 ---------------------------------------
4227 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
4228 Decl_Or_Stmt : Node_Id;
4231 if Unnest_Subprogram_Mode
4232 and then Present (Decls_Or_Stmts)
4234 Decl_Or_Stmt := First (Decls_Or_Stmts);
4235 while Present (Decl_Or_Stmt) loop
4236 if Nkind (Decl_Or_Stmt) = N_Block_Statement
4237 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
4239 Unnest_Block (Decl_Or_Stmt);
4241 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
4243 Id : constant Entity_Id :=
4244 Entity (Identifier (Decl_Or_Stmt));
4247 -- When a top-level loop within declarations of a library
4248 -- package spec or body contains nested subprograms, we wrap
4249 -- it in a procedure to handle possible up-level references
4250 -- to entities associated with the loop (such as loop
4253 if Present (Id) and then Contains_Subprogram (Id) then
4254 Unnest_Loop (Decl_Or_Stmt);
4258 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration
4259 and then not Modify_Tree_For_C
4261 Check_Unnesting_In_Decls_Or_Stmts
4262 (Visible_Declarations (Specification (Decl_Or_Stmt)));
4263 Check_Unnesting_In_Decls_Or_Stmts
4264 (Private_Declarations (Specification (Decl_Or_Stmt)));
4266 elsif Nkind (Decl_Or_Stmt) = N_Package_Body
4267 and then not Modify_Tree_For_C
4269 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
4270 if Present (Statements
4271 (Handled_Statement_Sequence (Decl_Or_Stmt)))
4273 Check_Unnesting_In_Decls_Or_Stmts (Statements
4274 (Handled_Statement_Sequence (Decl_Or_Stmt)));
4275 Check_Unnesting_In_Handlers (Decl_Or_Stmt);
4279 Next (Decl_Or_Stmt);
4282 end Check_Unnesting_In_Decls_Or_Stmts;
4284 ---------------------------------
4285 -- Check_Unnesting_In_Handlers --
4286 ---------------------------------
4288 procedure Check_Unnesting_In_Handlers (N : Node_Id) is
4289 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4292 if Present (Stmt_Seq)
4293 and then Present (Exception_Handlers (Stmt_Seq))
4296 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
4298 while Present (Handler) loop
4299 if Present (Statements (Handler)) then
4300 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
4307 end Check_Unnesting_In_Handlers;
4309 ------------------------------
4310 -- Check_Visibly_Controlled --
4311 ------------------------------
4313 procedure Check_Visibly_Controlled
4314 (Prim : Final_Primitives;
4316 E : in out Entity_Id;
4317 Cref : in out Node_Id)
4319 Parent_Type : Entity_Id;
4323 if Is_Derived_Type (Typ)
4324 and then Comes_From_Source (E)
4325 and then not Present (Overridden_Operation (E))
4327 -- We know that the explicit operation on the type does not override
4328 -- the inherited operation of the parent, and that the derivation
4329 -- is from a private type that is not visibly controlled.
4331 Parent_Type := Etype (Typ);
4332 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
4334 if Present (Op) then
4337 -- Wrap the object to be initialized into the proper
4338 -- unchecked conversion, to be compatible with the operation
4341 if Nkind (Cref) = N_Unchecked_Type_Conversion then
4342 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
4344 Cref := Unchecked_Convert_To (Parent_Type, Cref);
4348 end Check_Visibly_Controlled;
4350 --------------------------
4351 -- Contains_Subprogram --
4352 --------------------------
4354 function Contains_Subprogram (Blk : Entity_Id) return Boolean is
4358 E := First_Entity (Blk);
4360 while Present (E) loop
4361 if Is_Subprogram (E) then
4364 elsif Ekind_In (E, E_Block, E_Loop)
4365 and then Contains_Subprogram (E)
4374 end Contains_Subprogram;
4380 function Convert_View
4383 Ind : Pos := 1) return Node_Id
4385 Fent : Entity_Id := First_Entity (Proc);
4390 for J in 2 .. Ind loop
4394 Ftyp := Etype (Fent);
4396 if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
4397 Atyp := Entity (Subtype_Mark (Arg));
4399 Atyp := Etype (Arg);
4402 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
4403 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
4406 and then Present (Atyp)
4407 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
4408 and then Base_Type (Underlying_Type (Atyp)) =
4409 Base_Type (Underlying_Type (Ftyp))
4411 return Unchecked_Convert_To (Ftyp, Arg);
4413 -- If the argument is already a conversion, as generated by
4414 -- Make_Init_Call, set the target type to the type of the formal
4415 -- directly, to avoid spurious typing problems.
4417 elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
4418 and then not Is_Class_Wide_Type (Atyp)
4420 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
4421 Set_Etype (Arg, Ftyp);
4424 -- Otherwise, introduce a conversion when the designated object
4425 -- has a type derived from the formal of the controlled routine.
4427 elsif Is_Private_Type (Ftyp)
4428 and then Present (Atyp)
4429 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
4431 return Unchecked_Convert_To (Ftyp, Arg);
4438 -------------------------------
4439 -- CW_Or_Has_Controlled_Part --
4440 -------------------------------
4442 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
4444 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
4445 end CW_Or_Has_Controlled_Part;
4447 ------------------------
4448 -- Enclosing_Function --
4449 ------------------------
4451 function Enclosing_Function (E : Entity_Id) return Entity_Id is
4452 Func_Id : Entity_Id;
4456 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
4457 if Ekind (Func_Id) = E_Function then
4461 Func_Id := Scope (Func_Id);
4465 end Enclosing_Function;
4467 -------------------------------
4468 -- Establish_Transient_Scope --
4469 -------------------------------
4471 -- This procedure is called each time a transient block has to be inserted
4472 -- that is to say for each call to a function with unconstrained or tagged
4473 -- result. It creates a new scope on the scope stack in order to enclose
4474 -- all transient variables generated.
4476 procedure Establish_Transient_Scope
4478 Manage_Sec_Stack : Boolean)
4480 procedure Create_Transient_Scope (Constr : Node_Id);
4481 -- Place a new scope on the scope stack in order to service construct
4482 -- Constr. The new scope may also manage the secondary stack.
4484 procedure Delegate_Sec_Stack_Management;
4485 -- Move the management of the secondary stack to the nearest enclosing
4488 function Find_Enclosing_Transient_Scope return Entity_Id;
4489 -- Examine the scope stack looking for the nearest enclosing transient
4490 -- scope. Return Empty if no such scope exists.
4492 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
4493 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4495 ----------------------------
4496 -- Create_Transient_Scope --
4497 ----------------------------
4499 procedure Create_Transient_Scope (Constr : Node_Id) is
4500 Loc : constant Source_Ptr := Sloc (N);
4502 Iter_Loop : Entity_Id;
4503 Trans_Scop : Entity_Id;
4506 Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4507 Set_Etype (Trans_Scop, Standard_Void_Type);
4509 Push_Scope (Trans_Scop);
4510 Set_Node_To_Be_Wrapped (Constr);
4511 Set_Scope_Is_Transient;
4513 -- The transient scope must also manage the secondary stack
4515 if Manage_Sec_Stack then
4516 Set_Uses_Sec_Stack (Trans_Scop);
4517 Check_Restriction (No_Secondary_Stack, N);
4519 -- The expansion of iterator loops generates references to objects
4520 -- in order to extract elements from a container:
4522 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4523 -- Obj : <object type> renames Ref.all.Element.all;
4525 -- These references are controlled and returned on the secondary
4526 -- stack. A new reference is created at each iteration of the loop
4527 -- and as a result it must be finalized and the space occupied by
4528 -- it on the secondary stack reclaimed at the end of the current
4531 -- When the context that requires a transient scope is a call to
4532 -- routine Reference, the node to be wrapped is the source object:
4534 -- for Obj of Container loop
4536 -- Routine Wrap_Transient_Declaration however does not generate
4537 -- a physical block as wrapping a declaration will kill it too
4538 -- early. To handle this peculiar case, mark the related iterator
4539 -- loop as requiring the secondary stack. This signals the
4540 -- finalization machinery to manage the secondary stack (see
4541 -- routine Process_Statements_For_Controlled_Objects).
4543 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
4545 if Present (Iter_Loop) then
4546 Set_Uses_Sec_Stack (Iter_Loop);
4550 if Debug_Flag_W then
4551 Write_Str (" <Transient>");
4554 end Create_Transient_Scope;
4556 -----------------------------------
4557 -- Delegate_Sec_Stack_Management --
4558 -----------------------------------
4560 procedure Delegate_Sec_Stack_Management is
4561 Scop_Id : Entity_Id;
4562 Scop_Rec : Scope_Stack_Entry;
4565 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4566 Scop_Rec := Scope_Stack.Table (Index);
4567 Scop_Id := Scop_Rec.Entity;
4569 -- Prevent the search from going too far or within the scope space
4572 if Scop_Id = Standard_Standard then
4575 -- No transient scope should be encountered during the traversal
4576 -- because Establish_Transient_Scope should have already handled
4579 elsif Scop_Rec.Is_Transient then
4580 pragma Assert (False);
4583 -- The construct which requires secondary stack management is
4584 -- always enclosed by a package or subprogram scope.
4586 elsif Is_Package_Or_Subprogram (Scop_Id) then
4587 Set_Uses_Sec_Stack (Scop_Id);
4588 Check_Restriction (No_Secondary_Stack, N);
4594 -- At this point no suitable scope was found. This should never occur
4595 -- because a construct is always enclosed by a compilation unit which
4598 pragma Assert (False);
4599 end Delegate_Sec_Stack_Management;
4601 ------------------------------------
4602 -- Find_Enclosing_Transient_Scope --
4603 ------------------------------------
4605 function Find_Enclosing_Transient_Scope return Entity_Id is
4606 Scop_Id : Entity_Id;
4607 Scop_Rec : Scope_Stack_Entry;
4610 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4611 Scop_Rec := Scope_Stack.Table (Index);
4612 Scop_Id := Scop_Rec.Entity;
4614 -- Prevent the search from going too far or within the scope space
4617 if Scop_Id = Standard_Standard
4618 or else Is_Package_Or_Subprogram (Scop_Id)
4622 elsif Scop_Rec.Is_Transient then
4628 end Find_Enclosing_Transient_Scope;
4630 ------------------------------
4631 -- Is_Package_Or_Subprogram --
4632 ------------------------------
4634 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
4636 return Ekind_In (Id, E_Entry,
4642 end Is_Package_Or_Subprogram;
4646 Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
4649 -- Start of processing for Establish_Transient_Scope
4652 -- Do not create a new transient scope if there is an existing transient
4653 -- scope on the stack.
4655 if Present (Trans_Id) then
4657 -- If the transient scope was requested for purposes of managing the
4658 -- secondary stack, then the existing scope must perform this task.
4660 if Manage_Sec_Stack then
4661 Set_Uses_Sec_Stack (Trans_Id);
4667 -- At this point it is known that the scope stack is free of transient
4668 -- scopes. Locate the proper construct which must be serviced by a new
4671 Context := Find_Transient_Context (N);
4673 if Present (Context) then
4674 if Nkind (Context) = N_Assignment_Statement then
4676 -- An assignment statement with suppressed controlled semantics
4677 -- does not need a transient scope because finalization is not
4678 -- desirable at this point. Note that No_Ctrl_Actions is also
4679 -- set for non-controlled assignments to suppress dispatching
4682 if No_Ctrl_Actions (Context)
4683 and then Needs_Finalization (Etype (Name (Context)))
4685 -- When a controlled component is initialized by a function
4686 -- call, the result on the secondary stack is always assigned
4687 -- to the component. Signal the nearest suitable scope that it
4688 -- is safe to manage the secondary stack.
4690 if Manage_Sec_Stack and then Within_Init_Proc then
4691 Delegate_Sec_Stack_Management;
4694 -- Otherwise the assignment is a normal transient context and thus
4695 -- requires a transient scope.
4698 Create_Transient_Scope (Context);
4704 Create_Transient_Scope (Context);
4707 end Establish_Transient_Scope;
4709 ----------------------------
4710 -- Expand_Cleanup_Actions --
4711 ----------------------------
4713 procedure Expand_Cleanup_Actions (N : Node_Id) is
4714 pragma Assert (Nkind_In (N, N_Block_Statement,
4716 N_Extended_Return_Statement,
4720 Scop : constant Entity_Id := Current_Scope;
4722 Is_Asynchronous_Call : constant Boolean :=
4723 Nkind (N) = N_Block_Statement
4724 and then Is_Asynchronous_Call_Block (N);
4725 Is_Master : constant Boolean :=
4726 Nkind (N) /= N_Extended_Return_Statement
4727 and then Nkind (N) /= N_Entry_Body
4728 and then Is_Task_Master (N);
4729 Is_Protected_Subp_Body : constant Boolean :=
4730 Nkind (N) = N_Subprogram_Body
4731 and then Is_Protected_Subprogram_Body (N);
4732 Is_Task_Allocation : constant Boolean :=
4733 Nkind (N) = N_Block_Statement
4734 and then Is_Task_Allocation_Block (N);
4735 Is_Task_Body : constant Boolean :=
4736 Nkind (Original_Node (N)) = N_Task_Body;
4738 -- We mark the secondary stack if it is used in this construct, and
4739 -- we're not returning a function result on the secondary stack, except
4740 -- that a build-in-place function that might or might not return on the
4741 -- secondary stack always needs a mark. A run-time test is required in
4742 -- the case where the build-in-place function has a BIP_Alloc extra
4743 -- parameter (see Create_Finalizer).
4745 Needs_Sec_Stack_Mark : constant Boolean :=
4746 (Uses_Sec_Stack (Scop)
4748 not Sec_Stack_Needed_For_Return (Scop))
4750 (Is_Build_In_Place_Function (Scop)
4751 and then Needs_BIP_Alloc_Form (Scop));
4753 Needs_Custom_Cleanup : constant Boolean :=
4754 Nkind (N) = N_Block_Statement
4755 and then Present (Cleanup_Actions (N));
4757 Actions_Required : constant Boolean :=
4758 Requires_Cleanup_Actions (N, True)
4759 or else Is_Asynchronous_Call
4761 or else Is_Protected_Subp_Body
4762 or else Is_Task_Allocation
4763 or else Is_Task_Body
4764 or else Needs_Sec_Stack_Mark
4765 or else Needs_Custom_Cleanup;
4767 HSS : Node_Id := Handled_Statement_Sequence (N);
4771 procedure Wrap_HSS_In_Block;
4772 -- Move HSS inside a new block along with the original exception
4773 -- handlers. Make the newly generated block the sole statement of HSS.
4775 -----------------------
4776 -- Wrap_HSS_In_Block --
4777 -----------------------
4779 procedure Wrap_HSS_In_Block is
4781 Block_Id : Entity_Id;
4785 -- Preserve end label to provide proper cross-reference information
4787 End_Lab := End_Label (HSS);
4789 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
4791 Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4792 Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
4793 Set_Etype (Block_Id, Standard_Void_Type);
4794 Set_Block_Node (Block_Id, Identifier (Block));
4796 -- Signal the finalization machinery that this particular block
4797 -- contains the original context.
4799 Set_Is_Finalization_Wrapper (Block);
4801 Set_Handled_Statement_Sequence (N,
4802 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
4803 HSS := Handled_Statement_Sequence (N);
4805 Set_First_Real_Statement (HSS, Block);
4806 Set_End_Label (HSS, End_Lab);
4808 -- Comment needed here, see RH for 1.306 ???
4810 if Nkind (N) = N_Subprogram_Body then
4811 Set_Has_Nested_Block_With_Handler (Scop);
4813 end Wrap_HSS_In_Block;
4815 -- Start of processing for Expand_Cleanup_Actions
4818 -- The current construct does not need any form of servicing
4820 if not Actions_Required then
4823 -- If the current node is a rewritten task body and the descriptors have
4824 -- not been delayed (due to some nested instantiations), do not generate
4825 -- redundant cleanup actions.
4828 and then Nkind (N) = N_Subprogram_Body
4829 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
4834 -- If an extended return statement contains something like
4838 -- where F is a build-in-place function call returning a controlled
4839 -- type, then a temporary object will be implicitly declared as part
4840 -- of the statement list, and this will need cleanup. In such cases,
4843 -- return Result : T := ... do
4844 -- <statements> -- possibly with handlers
4849 -- return Result : T := ... do
4850 -- declare -- no declarations
4852 -- <statements> -- possibly with handlers
4853 -- end; -- no handlers
4856 -- So Expand_Cleanup_Actions will end up being called recursively on the
4859 if Nkind (N) = N_Extended_Return_Statement then
4861 Block : constant Node_Id :=
4862 Make_Block_Statement (Sloc (N),
4863 Declarations => Empty_List,
4864 Handled_Statement_Sequence =>
4865 Handled_Statement_Sequence (N));
4867 Set_Handled_Statement_Sequence (N,
4868 Make_Handled_Sequence_Of_Statements (Sloc (N),
4869 Statements => New_List (Block)));
4874 -- Analysis of the block did all the work
4879 if Needs_Custom_Cleanup then
4880 Cln := Cleanup_Actions (N);
4886 Decls : List_Id := Declarations (N);
4888 Mark : Entity_Id := Empty;
4889 New_Decls : List_Id;
4893 -- If we are generating expanded code for debugging purposes, use the
4894 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4895 -- be updated subsequently to reference the proper line in .dg files.
4896 -- If we are not debugging generated code, use No_Location instead,
4897 -- so that no debug information is generated for the cleanup code.
4898 -- This makes the behavior of the NEXT command in GDB monotonic, and
4899 -- makes the placement of breakpoints more accurate.
4901 if Debug_Generated_Code then
4907 -- Set polling off. The finalization and cleanup code is executed
4908 -- with aborts deferred.
4910 Old_Poll := Polling_Required;
4911 Polling_Required := False;
4913 -- A task activation call has already been built for a task
4914 -- allocation block.
4916 if not Is_Task_Allocation then
4917 Build_Task_Activation_Call (N);
4921 Establish_Task_Master (N);
4924 New_Decls := New_List;
4926 -- If secondary stack is in use, generate:
4928 -- Mnn : constant Mark_Id := SS_Mark;
4930 if Needs_Sec_Stack_Mark then
4931 Mark := Make_Temporary (Loc, 'M');
4933 Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
4934 Set_Uses_Sec_Stack (Scop, False);
4937 -- If exception handlers are present, wrap the sequence of statements
4938 -- in a block since it is not possible to have exception handlers and
4939 -- an At_End handler in the same construct.
4941 if Present (Exception_Handlers (HSS)) then
4944 -- Ensure that the First_Real_Statement field is set
4946 elsif No (First_Real_Statement (HSS)) then
4947 Set_First_Real_Statement (HSS, First (Statements (HSS)));
4950 -- Do not move the Activation_Chain declaration in the context of
4951 -- task allocation blocks. Task allocation blocks use _chain in their
4952 -- cleanup handlers and gigi complains if it is declared in the
4953 -- sequence of statements of the scope that declares the handler.
4955 if Is_Task_Allocation then
4957 Chain : constant Entity_Id := Activation_Chain_Entity (N);
4961 Decl := First (Decls);
4962 while Nkind (Decl) /= N_Object_Declaration
4963 or else Defining_Identifier (Decl) /= Chain
4967 -- A task allocation block should always include a _chain
4970 pragma Assert (Present (Decl));
4974 Prepend_To (New_Decls, Decl);
4978 -- Ensure the presence of a declaration list in order to successfully
4979 -- append all original statements to it.
4982 Set_Declarations (N, New_List);
4983 Decls := Declarations (N);
4986 -- Move the declarations into the sequence of statements in order to
4987 -- have them protected by the At_End handler. It may seem weird to
4988 -- put declarations in the sequence of statement but in fact nothing
4989 -- forbids that at the tree level.
4991 Append_List_To (Decls, Statements (HSS));
4992 Set_Statements (HSS, Decls);
4994 -- Reset the Sloc of the handled statement sequence to properly
4995 -- reflect the new initial "statement" in the sequence.
4997 Set_Sloc (HSS, Sloc (First (Decls)));
4999 -- The declarations of finalizer spec and auxiliary variables replace
5000 -- the old declarations that have been moved inward.
5002 Set_Declarations (N, New_Decls);
5003 Analyze_Declarations (New_Decls);
5005 -- Generate finalization calls for all controlled objects appearing
5006 -- in the statements of N. Add context specific cleanup for various
5011 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
5013 Top_Decls => New_Decls,
5014 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
5018 if Present (Fin_Id) then
5019 Build_Finalizer_Call (N, Fin_Id);
5022 -- Restore saved polling mode
5024 Polling_Required := Old_Poll;
5026 end Expand_Cleanup_Actions;
5028 ---------------------------
5029 -- Expand_N_Package_Body --
5030 ---------------------------
5032 -- Add call to Activate_Tasks if body is an activator (actual processing
5033 -- is in chapter 9).
5035 -- Generate subprogram descriptor for elaboration routine
5037 -- Encode entity names in package body
5039 procedure Expand_N_Package_Body (N : Node_Id) is
5040 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
5044 -- This is done only for non-generic packages
5046 if Ekind (Spec_Id) = E_Package then
5047 Push_Scope (Spec_Id);
5049 -- Build dispatch tables of library level tagged types
5051 if Tagged_Type_Expansion
5052 and then Is_Library_Level_Entity (Spec_Id)
5054 Build_Static_Dispatch_Tables (N);
5057 Build_Task_Activation_Call (N);
5059 -- Verify the run-time semantics of pragma Initial_Condition at the
5060 -- end of the body statements.
5062 Expand_Pragma_Initial_Condition (Spec_Id, N);
5064 -- If this is a library-level package and unnesting is enabled,
5065 -- check for the presence of blocks with nested subprograms occurring
5066 -- in elaboration code, and generate procedures to encapsulate the
5067 -- blocks in case the nested subprograms make up-level references.
5069 if Unnest_Subprogram_Mode
5071 Is_Library_Level_Entity (Current_Scope)
5073 Check_Unnesting_Elaboration_Code (N);
5074 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
5075 Check_Unnesting_In_Handlers (N);
5081 Set_Elaboration_Flag (N, Spec_Id);
5082 Set_In_Package_Body (Spec_Id, False);
5084 -- Set to encode entity names in package body before gigi is called
5086 Qualify_Entity_Names (N);
5088 if Ekind (Spec_Id) /= E_Generic_Package then
5091 Clean_Stmts => No_List,
5093 Top_Decls => No_List,
5094 Defer_Abort => False,
5097 if Present (Fin_Id) then
5099 Body_Ent : Node_Id := Defining_Unit_Name (N);
5102 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
5103 Body_Ent := Defining_Identifier (Body_Ent);
5106 Set_Finalizer (Body_Ent, Fin_Id);
5110 end Expand_N_Package_Body;
5112 ----------------------------------
5113 -- Expand_N_Package_Declaration --
5114 ----------------------------------
5116 -- Add call to Activate_Tasks if there are tasks declared and the package
5117 -- has no body. Note that in Ada 83 this may result in premature activation
5118 -- of some tasks, given that we cannot tell whether a body will eventually
5121 procedure Expand_N_Package_Declaration (N : Node_Id) is
5122 Id : constant Entity_Id := Defining_Entity (N);
5123 Spec : constant Node_Id := Specification (N);
5127 No_Body : Boolean := False;
5128 -- True in the case of a package declaration that is a compilation
5129 -- unit and for which no associated body will be compiled in this
5133 -- Case of a package declaration other than a compilation unit
5135 if Nkind (Parent (N)) /= N_Compilation_Unit then
5138 -- Case of a compilation unit that does not require a body
5140 elsif not Body_Required (Parent (N))
5141 and then not Unit_Requires_Body (Id)
5145 -- Special case of generating calling stubs for a remote call interface
5146 -- package: even though the package declaration requires one, the body
5147 -- won't be processed in this compilation (so any stubs for RACWs
5148 -- declared in the package must be generated here, along with the spec).
5150 elsif Parent (N) = Cunit (Main_Unit)
5151 and then Is_Remote_Call_Interface (Id)
5152 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
5157 -- For a nested instance, delay processing until freeze point
5159 if Has_Delayed_Freeze (Id)
5160 and then Nkind (Parent (N)) /= N_Compilation_Unit
5165 -- For a package declaration that implies no associated body, generate
5166 -- task activation call and RACW supporting bodies now (since we won't
5167 -- have a specific separate compilation unit for that).
5172 -- Generate RACW subprogram bodies
5174 if Has_RACW (Id) then
5175 Decls := Private_Declarations (Spec);
5178 Decls := Visible_Declarations (Spec);
5183 Set_Visible_Declarations (Spec, Decls);
5186 Append_RACW_Bodies (Decls, Id);
5187 Analyze_List (Decls);
5190 -- Generate task activation call as last step of elaboration
5192 if Present (Activation_Chain_Entity (N)) then
5193 Build_Task_Activation_Call (N);
5196 -- Verify the run-time semantics of pragma Initial_Condition at the
5197 -- end of the private declarations when the package lacks a body.
5199 Expand_Pragma_Initial_Condition (Id, N);
5204 -- Build dispatch tables of library level tagged types
5206 if Tagged_Type_Expansion
5207 and then (Is_Compilation_Unit (Id)
5208 or else (Is_Generic_Instance (Id)
5209 and then Is_Library_Level_Entity (Id)))
5211 Build_Static_Dispatch_Tables (N);
5214 -- Note: it is not necessary to worry about generating a subprogram
5215 -- descriptor, since the only way to get exception handlers into a
5216 -- package spec is to include instantiations, and that would cause
5217 -- generation of subprogram descriptors to be delayed in any case.
5219 -- Set to encode entity names in package spec before gigi is called
5221 Qualify_Entity_Names (N);
5223 if Ekind (Id) /= E_Generic_Package then
5226 Clean_Stmts => No_List,
5228 Top_Decls => No_List,
5229 Defer_Abort => False,
5232 Set_Finalizer (Id, Fin_Id);
5235 -- If this is a library-level package and unnesting is enabled,
5236 -- check for the presence of blocks with nested subprograms occurring
5237 -- in elaboration code, and generate procedures to encapsulate the
5238 -- blocks in case the nested subprograms make up-level references.
5240 if Unnest_Subprogram_Mode
5241 and then Is_Library_Level_Entity (Current_Scope)
5243 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
5244 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
5246 end Expand_N_Package_Declaration;
5248 ----------------------------
5249 -- Find_Transient_Context --
5250 ----------------------------
5252 function Find_Transient_Context (N : Node_Id) return Node_Id is
5259 while Present (Curr) loop
5260 case Nkind (Curr) is
5264 -- Declarations act as a boundary for a transient scope even if
5265 -- they are not wrapped, see Wrap_Transient_Declaration.
5267 when N_Object_Declaration
5268 | N_Object_Renaming_Declaration
5269 | N_Subtype_Declaration
5275 -- Statements and statement-like constructs act as a boundary for
5276 -- a transient scope.
5278 when N_Accept_Alternative
5279 | N_Attribute_Definition_Clause
5281 | N_Case_Statement_Alternative
5283 | N_Delay_Alternative
5284 | N_Delay_Until_Statement
5285 | N_Delay_Relative_Statement
5286 | N_Discriminant_Association
5288 | N_Entry_Body_Formal_Part
5291 | N_Iteration_Scheme
5292 | N_Terminate_Alternative
5294 pragma Assert (Present (Prev));
5297 when N_Assignment_Statement =>
5300 when N_Entry_Call_Statement
5301 | N_Procedure_Call_Statement
5303 -- When an entry or procedure call acts as the alternative of a
5304 -- conditional or timed entry call, the proper context is that
5305 -- of the alternative.
5307 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
5308 and then Nkind_In (Parent (Parent (Curr)),
5309 N_Conditional_Entry_Call,
5312 return Parent (Parent (Curr));
5314 -- General case for entry or procedure calls
5322 -- Pragma Check is not a valid transient context in GNATprove
5323 -- mode because the pragma must remain unchanged.
5326 and then Get_Pragma_Id (Curr) = Pragma_Check
5330 -- General case for pragmas
5336 when N_Raise_Statement =>
5339 when N_Simple_Return_Statement =>
5341 -- A return statement is not a valid transient context when the
5342 -- function itself requires transient scope management because
5343 -- the result will be reclaimed too early.
5345 if Requires_Transient_Scope (Etype
5346 (Return_Applies_To (Return_Statement_Entity (Curr))))
5350 -- General case for return statements
5358 when N_Attribute_Reference =>
5359 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
5363 -- An Ada 2012 iterator specification is not a valid context
5364 -- because Analyze_Iterator_Specification already employs special
5365 -- processing for it.
5367 when N_Iterator_Specification =>
5370 when N_Loop_Parameter_Specification =>
5372 -- An iteration scheme is not a valid context because routine
5373 -- Analyze_Iteration_Scheme already employs special processing.
5375 if Nkind (Parent (Curr)) = N_Iteration_Scheme then
5378 return Parent (Curr);
5383 -- The following nodes represent "dummy contexts" which do not
5384 -- need to be wrapped.
5386 when N_Component_Declaration
5387 | N_Discriminant_Specification
5388 | N_Parameter_Specification
5392 -- If the traversal leaves a scope without having been able to
5393 -- find a construct to wrap, something is going wrong, but this
5394 -- can happen in error situations that are not detected yet (such
5395 -- as a dynamic string in a pragma Export).
5397 when N_Block_Statement
5400 | N_Package_Declaration
5414 Curr := Parent (Curr);
5418 end Find_Transient_Context;
5420 ----------------------------------
5421 -- Has_New_Controlled_Component --
5422 ----------------------------------
5424 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
5428 if not Is_Tagged_Type (E) then
5429 return Has_Controlled_Component (E);
5430 elsif not Is_Derived_Type (E) then
5431 return Has_Controlled_Component (E);
5434 Comp := First_Component (E);
5435 while Present (Comp) loop
5436 if Chars (Comp) = Name_uParent then
5439 elsif Scope (Original_Record_Component (Comp)) = E
5440 and then Needs_Finalization (Etype (Comp))
5445 Next_Component (Comp);
5449 end Has_New_Controlled_Component;
5451 ---------------------------------
5452 -- Has_Simple_Protected_Object --
5453 ---------------------------------
5455 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
5457 if Has_Task (T) then
5460 elsif Is_Simple_Protected_Type (T) then
5463 elsif Is_Array_Type (T) then
5464 return Has_Simple_Protected_Object (Component_Type (T));
5466 elsif Is_Record_Type (T) then
5471 Comp := First_Component (T);
5472 while Present (Comp) loop
5473 if Has_Simple_Protected_Object (Etype (Comp)) then
5477 Next_Component (Comp);
5486 end Has_Simple_Protected_Object;
5488 ------------------------------------
5489 -- Insert_Actions_In_Scope_Around --
5490 ------------------------------------
5492 procedure Insert_Actions_In_Scope_Around
5495 Manage_SS : Boolean)
5497 Act_Before : constant List_Id :=
5498 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
5499 Act_After : constant List_Id :=
5500 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
5501 Act_Cleanup : constant List_Id :=
5502 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
5503 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5504 -- Last), but this was incorrect as Process_Transients_In_Scope may
5505 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5507 procedure Process_Transients_In_Scope
5508 (First_Object : Node_Id;
5509 Last_Object : Node_Id;
5510 Related_Node : Node_Id);
5511 -- Find all transient objects in the list First_Object .. Last_Object
5512 -- and generate finalization actions for them. Related_Node denotes the
5513 -- node which created all transient objects.
5515 ---------------------------------
5516 -- Process_Transients_In_Scope --
5517 ---------------------------------
5519 procedure Process_Transients_In_Scope
5520 (First_Object : Node_Id;
5521 Last_Object : Node_Id;
5522 Related_Node : Node_Id)
5524 Must_Hook : Boolean := False;
5525 -- Flag denoting whether the context requires transient object
5526 -- export to the outer finalizer.
5528 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
5529 -- Determine whether an arbitrary node denotes a subprogram call
5531 procedure Detect_Subprogram_Call is
5532 new Traverse_Proc (Is_Subprogram_Call);
5534 procedure Process_Transient_In_Scope
5535 (Obj_Decl : Node_Id;
5536 Blk_Data : Finalization_Exception_Data;
5537 Blk_Stmts : List_Id);
5538 -- Generate finalization actions for a single transient object
5539 -- denoted by object declaration Obj_Decl. Blk_Data is the
5540 -- exception data of the enclosing block. Blk_Stmts denotes the
5541 -- statements of the enclosing block.
5543 ------------------------
5544 -- Is_Subprogram_Call --
5545 ------------------------
5547 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
5549 -- A regular procedure or function call
5551 if Nkind (N) in N_Subprogram_Call then
5557 -- Heavy expansion may relocate function calls outside the related
5558 -- node. Inspect the original node to detect the initial placement
5561 elsif Is_Rewrite_Substitution (N) then
5562 Detect_Subprogram_Call (Original_Node (N));
5570 -- Generalized indexing always involves a function call
5572 elsif Nkind (N) = N_Indexed_Component
5573 and then Present (Generalized_Indexing (N))
5583 end Is_Subprogram_Call;
5585 --------------------------------
5586 -- Process_Transient_In_Scope --
5587 --------------------------------
5589 procedure Process_Transient_In_Scope
5590 (Obj_Decl : Node_Id;
5591 Blk_Data : Finalization_Exception_Data;
5592 Blk_Stmts : List_Id)
5594 Loc : constant Source_Ptr := Sloc (Obj_Decl);
5595 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
5597 Fin_Stmts : List_Id;
5598 Hook_Assign : Node_Id;
5599 Hook_Clear : Node_Id;
5600 Hook_Decl : Node_Id;
5601 Hook_Insert : Node_Id;
5605 -- Mark the transient object as successfully processed to avoid
5606 -- double finalization.
5608 Set_Is_Finalized_Transient (Obj_Id);
5610 -- Construct all the pieces necessary to hook and finalize the
5611 -- transient object.
5613 Build_Transient_Object_Statements
5614 (Obj_Decl => Obj_Decl,
5615 Fin_Call => Fin_Call,
5616 Hook_Assign => Hook_Assign,
5617 Hook_Clear => Hook_Clear,
5618 Hook_Decl => Hook_Decl,
5619 Ptr_Decl => Ptr_Decl);
5621 -- The context contains at least one subprogram call which may
5622 -- raise an exception. This scenario employs "hooking" to pass
5623 -- transient objects to the enclosing finalizer in case of an
5628 -- Add the access type which provides a reference to the
5629 -- transient object. Generate:
5631 -- type Ptr_Typ is access all Desig_Typ;
5633 Insert_Action (Obj_Decl, Ptr_Decl);
5635 -- Add the temporary which acts as a hook to the transient
5636 -- object. Generate:
5638 -- Hook : Ptr_Typ := null;
5640 Insert_Action (Obj_Decl, Hook_Decl);
5642 -- When the transient object is initialized by an aggregate,
5643 -- the hook must capture the object after the last aggregate
5644 -- assignment takes place. Only then is the object considered
5645 -- fully initialized. Generate:
5647 -- Hook := Ptr_Typ (Obj_Id);
5649 -- Hook := Obj_Id'Unrestricted_Access;
5651 if Ekind_In (Obj_Id, E_Constant, E_Variable)
5652 and then Present (Last_Aggregate_Assignment (Obj_Id))
5654 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
5656 -- Otherwise the hook seizes the related object immediately
5659 Hook_Insert := Obj_Decl;
5662 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
5665 -- When exception propagation is enabled wrap the hook clear
5666 -- statement and the finalization call into a block to catch
5667 -- potential exceptions raised during finalization. Generate:
5671 -- [Deep_]Finalize (Obj_Ref);
5675 -- if not Raised then
5678 -- (Enn, Get_Current_Excep.all.all);
5682 if Exceptions_OK then
5683 Fin_Stmts := New_List;
5686 Append_To (Fin_Stmts, Hook_Clear);
5689 Append_To (Fin_Stmts, Fin_Call);
5691 Prepend_To (Blk_Stmts,
5692 Make_Block_Statement (Loc,
5693 Handled_Statement_Sequence =>
5694 Make_Handled_Sequence_Of_Statements (Loc,
5695 Statements => Fin_Stmts,
5696 Exception_Handlers => New_List (
5697 Build_Exception_Handler (Blk_Data)))));
5699 -- Otherwise generate:
5702 -- [Deep_]Finalize (Obj_Ref);
5704 -- Note that the statements are inserted in reverse order to
5705 -- achieve the desired final order outlined above.
5708 Prepend_To (Blk_Stmts, Fin_Call);
5711 Prepend_To (Blk_Stmts, Hook_Clear);
5714 end Process_Transient_In_Scope;
5718 Built : Boolean := False;
5719 Blk_Data : Finalization_Exception_Data;
5720 Blk_Decl : Node_Id := Empty;
5721 Blk_Decls : List_Id := No_List;
5723 Blk_Stmts : List_Id;
5727 -- Start of processing for Process_Transients_In_Scope
5730 -- The expansion performed by this routine is as follows:
5732 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5733 -- Hook_1 : Ptr_Typ_1 := null;
5734 -- Ctrl_Trans_Obj_1 : ...;
5735 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5737 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5738 -- Hook_N : Ptr_Typ_N := null;
5739 -- Ctrl_Trans_Obj_N : ...;
5740 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5743 -- Abrt : constant Boolean := ...;
5744 -- Ex : Exception_Occurrence;
5745 -- Raised : Boolean := False;
5752 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5756 -- if not Raised then
5758 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5763 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5767 -- if not Raised then
5769 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5774 -- if Raised and not Abrt then
5775 -- Raise_From_Controlled_Operation (Ex);
5779 -- Recognize a scenario where the transient context is an object
5780 -- declaration initialized by a build-in-place function call:
5782 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5784 -- The rough expansion of the above is:
5786 -- Temp : ... := Ctrl_Func_Call;
5788 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5790 -- The finalization of any transient object must happen after the
5791 -- build-in-place function call is executed.
5793 if Nkind (N) = N_Object_Declaration
5794 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
5797 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
5799 -- Search the context for at least one subprogram call. If found, the
5800 -- machinery exports all transient objects to the enclosing finalizer
5801 -- due to the possibility of abnormal call termination.
5804 Detect_Subprogram_Call (N);
5805 Blk_Ins := Last_Object;
5809 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
5812 -- Examine all objects in the list First_Object .. Last_Object
5814 Obj_Decl := First_Object;
5815 while Present (Obj_Decl) loop
5816 if Nkind (Obj_Decl) = N_Object_Declaration
5817 and then Analyzed (Obj_Decl)
5818 and then Is_Finalizable_Transient (Obj_Decl, N)
5820 -- Do not process the node to be wrapped since it will be
5821 -- handled by the enclosing finalizer.
5823 and then Obj_Decl /= Related_Node
5825 Loc := Sloc (Obj_Decl);
5827 -- Before generating the cleanup code for the first transient
5828 -- object, create a wrapper block which houses all hook clear
5829 -- statements and finalization calls. This wrapper is needed by
5834 Blk_Stmts := New_List;
5837 -- Abrt : constant Boolean := ...;
5838 -- Ex : Exception_Occurrence;
5839 -- Raised : Boolean := False;
5841 if Exceptions_OK then
5842 Blk_Decls := New_List;
5843 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
5847 Make_Block_Statement (Loc,
5848 Declarations => Blk_Decls,
5849 Handled_Statement_Sequence =>
5850 Make_Handled_Sequence_Of_Statements (Loc,
5851 Statements => Blk_Stmts));
5854 -- Construct all necessary circuitry to hook and finalize a
5855 -- single transient object.
5857 Process_Transient_In_Scope
5858 (Obj_Decl => Obj_Decl,
5859 Blk_Data => Blk_Data,
5860 Blk_Stmts => Blk_Stmts);
5863 -- Terminate the scan after the last object has been processed to
5864 -- avoid touching unrelated code.
5866 if Obj_Decl = Last_Object then
5873 -- Complete the decoration of the enclosing finalization block and
5874 -- insert it into the tree.
5876 if Present (Blk_Decl) then
5878 -- Note that this Abort_Undefer does not require a extra block or
5879 -- an AT_END handler because each finalization exception is caught
5880 -- in its own corresponding finalization block. As a result, the
5881 -- call to Abort_Defer always takes place.
5883 if Abort_Allowed then
5884 Prepend_To (Blk_Stmts,
5885 Build_Runtime_Call (Loc, RE_Abort_Defer));
5887 Append_To (Blk_Stmts,
5888 Build_Runtime_Call (Loc, RE_Abort_Undefer));
5892 -- if Raised and then not Abrt then
5893 -- Raise_From_Controlled_Operation (Ex);
5896 if Exceptions_OK then
5897 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
5900 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
5902 end Process_Transients_In_Scope;
5906 Loc : constant Source_Ptr := Sloc (N);
5907 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
5908 First_Obj : Node_Id;
5910 Mark_Id : Entity_Id;
5913 -- Start of processing for Insert_Actions_In_Scope_Around
5916 -- Nothing to do if the scope does not manage the secondary stack or
5917 -- does not contain meaninful actions for insertion.
5920 and then No (Act_Before)
5921 and then No (Act_After)
5922 and then No (Act_Cleanup)
5927 -- If the node to be wrapped is the trigger of an asynchronous select,
5928 -- it is not part of a statement list. The actions must be inserted
5929 -- before the select itself, which is part of some list of statements.
5930 -- Note that the triggering alternative includes the triggering
5931 -- statement and an optional statement list. If the node to be
5932 -- wrapped is part of that list, the normal insertion applies.
5934 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
5935 and then not Is_List_Member (Node_To_Wrap)
5937 Target := Parent (Parent (Node_To_Wrap));
5942 First_Obj := Target;
5945 -- Add all actions associated with a transient scope into the main tree.
5946 -- There are several scenarios here:
5948 -- +--- Before ----+ +----- After ---+
5949 -- 1) First_Obj ....... Target ........ Last_Obj
5951 -- 2) First_Obj ....... Target
5953 -- 3) Target ........ Last_Obj
5955 -- Flag declarations are inserted before the first object
5957 if Present (Act_Before) then
5958 First_Obj := First (Act_Before);
5959 Insert_List_Before (Target, Act_Before);
5962 -- Finalization calls are inserted after the last object
5964 if Present (Act_After) then
5965 Last_Obj := Last (Act_After);
5966 Insert_List_After (Target, Act_After);
5969 -- Mark and release the secondary stack when the context warrants it
5972 Mark_Id := Make_Temporary (Loc, 'M');
5975 -- Mnn : constant Mark_Id := SS_Mark;
5977 Insert_Before_And_Analyze
5978 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
5981 -- SS_Release (Mnn);
5983 Insert_After_And_Analyze
5984 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
5987 -- Check for transient objects associated with Target and generate the
5988 -- appropriate finalization actions for them.
5990 Process_Transients_In_Scope
5991 (First_Object => First_Obj,
5992 Last_Object => Last_Obj,
5993 Related_Node => Target);
5995 -- Reset the action lists
5998 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
6000 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
6004 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
6006 end Insert_Actions_In_Scope_Around;
6008 ------------------------------
6009 -- Is_Simple_Protected_Type --
6010 ------------------------------
6012 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
6015 Is_Protected_Type (T)
6016 and then not Uses_Lock_Free (T)
6017 and then not Has_Entries (T)
6018 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
6019 end Is_Simple_Protected_Type;
6021 -----------------------
6022 -- Make_Adjust_Call --
6023 -----------------------
6025 function Make_Adjust_Call
6028 Skip_Self : Boolean := False) return Node_Id
6030 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6031 Adj_Id : Entity_Id := Empty;
6038 -- Recover the proper type which contains Deep_Adjust
6040 if Is_Class_Wide_Type (Typ) then
6041 Utyp := Root_Type (Typ);
6046 Utyp := Underlying_Type (Base_Type (Utyp));
6047 Set_Assignment_OK (Ref);
6049 -- Deal with untagged derivation of private views
6051 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
6052 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6053 Ref := Unchecked_Convert_To (Utyp, Ref);
6054 Set_Assignment_OK (Ref);
6057 -- When dealing with the completion of a private type, use the base
6060 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
6061 pragma Assert (Is_Private_Type (Typ));
6063 Utyp := Base_Type (Utyp);
6064 Ref := Unchecked_Convert_To (Utyp, Ref);
6067 -- The underlying type may not be present due to a missing full view. In
6068 -- this case freezing did not take place and there is no [Deep_]Adjust
6069 -- primitive to call.
6074 elsif Skip_Self then
6075 if Has_Controlled_Component (Utyp) then
6076 if Is_Tagged_Type (Utyp) then
6077 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6079 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6083 -- Class-wide types, interfaces and types with controlled components
6085 elsif Is_Class_Wide_Type (Typ)
6086 or else Is_Interface (Typ)
6087 or else Has_Controlled_Component (Utyp)
6089 if Is_Tagged_Type (Utyp) then
6090 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6092 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6095 -- Derivations from [Limited_]Controlled
6097 elsif Is_Controlled (Utyp) then
6098 if Has_Controlled_Component (Utyp) then
6099 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6101 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
6106 elsif Is_Tagged_Type (Utyp) then
6107 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6110 raise Program_Error;
6113 if Present (Adj_Id) then
6115 -- If the object is unanalyzed, set its expected type for use in
6116 -- Convert_View in case an additional conversion is needed.
6119 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
6121 Set_Etype (Ref, Typ);
6124 -- The object reference may need another conversion depending on the
6125 -- type of the formal and that of the actual.
6127 if not Is_Class_Wide_Type (Typ) then
6128 Ref := Convert_View (Adj_Id, Ref);
6135 Skip_Self => Skip_Self);
6139 end Make_Adjust_Call;
6141 ----------------------
6142 -- Make_Detach_Call --
6143 ----------------------
6145 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
6146 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6150 Make_Procedure_Call_Statement (Loc,
6152 New_Occurrence_Of (RTE (RE_Detach), Loc),
6153 Parameter_Associations => New_List (
6154 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
6155 end Make_Detach_Call;
6163 Proc_Id : Entity_Id;
6165 Skip_Self : Boolean := False) return Node_Id
6167 Params : constant List_Id := New_List (Param);
6170 -- Do not apply the controlled action to the object itself by signaling
6171 -- the related routine to avoid self.
6174 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
6178 Make_Procedure_Call_Statement (Loc,
6179 Name => New_Occurrence_Of (Proc_Id, Loc),
6180 Parameter_Associations => Params);
6183 --------------------------
6184 -- Make_Deep_Array_Body --
6185 --------------------------
6187 function Make_Deep_Array_Body
6188 (Prim : Final_Primitives;
6189 Typ : Entity_Id) return List_Id
6191 function Build_Adjust_Or_Finalize_Statements
6192 (Typ : Entity_Id) return List_Id;
6193 -- Create the statements necessary to adjust or finalize an array of
6194 -- controlled elements. Generate:
6197 -- Abort : constant Boolean := Triggered_By_Abort;
6199 -- Abort : constant Boolean := False; -- no abort
6201 -- E : Exception_Occurrence;
6202 -- Raised : Boolean := False;
6205 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6206 -- ^-- in the finalization case
6208 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6210 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6214 -- if not Raised then
6216 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6223 -- if Raised and then not Abort then
6224 -- Raise_From_Controlled_Operation (E);
6228 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
6229 -- Create the statements necessary to initialize an array of controlled
6230 -- elements. Include a mechanism to carry out partial finalization if an
6231 -- exception occurs. Generate:
6234 -- Counter : Integer := 0;
6237 -- for J1 in V'Range (1) loop
6239 -- for JN in V'Range (N) loop
6241 -- [Deep_]Initialize (V (J1, ..., JN));
6243 -- Counter := Counter + 1;
6248 -- Abort : constant Boolean := Triggered_By_Abort;
6250 -- Abort : constant Boolean := False; -- no abort
6251 -- E : Exception_Occurrence;
6252 -- Raised : Boolean := False;
6259 -- V'Length (N) - Counter;
6261 -- for F1 in reverse V'Range (1) loop
6263 -- for FN in reverse V'Range (N) loop
6264 -- if Counter > 0 then
6265 -- Counter := Counter - 1;
6268 -- [Deep_]Finalize (V (F1, ..., FN));
6272 -- if not Raised then
6274 -- Save_Occurrence (E,
6275 -- Get_Current_Excep.all.all);
6284 -- if Raised and then not Abort then
6285 -- Raise_From_Controlled_Operation (E);
6294 function New_References_To
6296 Loc : Source_Ptr) return List_Id;
6297 -- Given a list of defining identifiers, return a list of references to
6298 -- the original identifiers, in the same order as they appear.
6300 -----------------------------------------
6301 -- Build_Adjust_Or_Finalize_Statements --
6302 -----------------------------------------
6304 function Build_Adjust_Or_Finalize_Statements
6305 (Typ : Entity_Id) return List_Id
6307 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6308 Index_List : constant List_Id := New_List;
6309 Loc : constant Source_Ptr := Sloc (Typ);
6310 Num_Dims : constant Int := Number_Dimensions (Typ);
6312 procedure Build_Indexes;
6313 -- Generate the indexes used in the dimension loops
6319 procedure Build_Indexes is
6321 -- Generate the following identifiers:
6322 -- Jnn - for initialization
6324 for Dim in 1 .. Num_Dims loop
6325 Append_To (Index_List,
6326 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6332 Final_Decls : List_Id := No_List;
6333 Final_Data : Finalization_Exception_Data;
6337 Core_Loop : Node_Id;
6340 Loop_Id : Entity_Id;
6343 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6346 Final_Decls := New_List;
6349 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6352 Make_Indexed_Component (Loc,
6353 Prefix => Make_Identifier (Loc, Name_V),
6354 Expressions => New_References_To (Index_List, Loc));
6355 Set_Etype (Comp_Ref, Comp_Typ);
6358 -- [Deep_]Adjust (V (J1, ..., JN))
6360 if Prim = Adjust_Case then
6361 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6364 -- [Deep_]Finalize (V (J1, ..., JN))
6366 else pragma Assert (Prim = Finalize_Case);
6367 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6370 if Present (Call) then
6372 -- Generate the block which houses the adjust or finalize call:
6375 -- <adjust or finalize call>
6379 -- if not Raised then
6381 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6385 if Exceptions_OK then
6387 Make_Block_Statement (Loc,
6388 Handled_Statement_Sequence =>
6389 Make_Handled_Sequence_Of_Statements (Loc,
6390 Statements => New_List (Call),
6391 Exception_Handlers => New_List (
6392 Build_Exception_Handler (Final_Data))));
6397 -- Generate the dimension loops starting from the innermost one
6399 -- for Jnn in [reverse] V'Range (Dim) loop
6403 J := Last (Index_List);
6405 while Present (J) and then Dim > 0 loop
6411 Make_Loop_Statement (Loc,
6413 Make_Iteration_Scheme (Loc,
6414 Loop_Parameter_Specification =>
6415 Make_Loop_Parameter_Specification (Loc,
6416 Defining_Identifier => Loop_Id,
6417 Discrete_Subtype_Definition =>
6418 Make_Attribute_Reference (Loc,
6419 Prefix => Make_Identifier (Loc, Name_V),
6420 Attribute_Name => Name_Range,
6421 Expressions => New_List (
6422 Make_Integer_Literal (Loc, Dim))),
6425 Prim = Finalize_Case)),
6427 Statements => New_List (Core_Loop),
6428 End_Label => Empty);
6433 -- Generate the block which contains the core loop, declarations
6434 -- of the abort flag, the exception occurrence, the raised flag
6435 -- and the conditional raise:
6438 -- Abort : constant Boolean := Triggered_By_Abort;
6440 -- Abort : constant Boolean := False; -- no abort
6442 -- E : Exception_Occurrence;
6443 -- Raised : Boolean := False;
6448 -- if Raised and then not Abort then
6449 -- Raise_From_Controlled_Operation (E);
6453 Stmts := New_List (Core_Loop);
6455 if Exceptions_OK then
6456 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6460 Make_Block_Statement (Loc,
6461 Declarations => Final_Decls,
6462 Handled_Statement_Sequence =>
6463 Make_Handled_Sequence_Of_Statements (Loc,
6464 Statements => Stmts));
6466 -- Otherwise previous errors or a missing full view may prevent the
6467 -- proper freezing of the component type. If this is the case, there
6468 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6471 Block := Make_Null_Statement (Loc);
6474 return New_List (Block);
6475 end Build_Adjust_Or_Finalize_Statements;
6477 ---------------------------------
6478 -- Build_Initialize_Statements --
6479 ---------------------------------
6481 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
6482 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6483 Final_List : constant List_Id := New_List;
6484 Index_List : constant List_Id := New_List;
6485 Loc : constant Source_Ptr := Sloc (Typ);
6486 Num_Dims : constant Int := Number_Dimensions (Typ);
6488 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
6489 -- Generate the following assignment:
6490 -- Counter := V'Length (1) *
6492 -- V'Length (N) - Counter;
6494 -- Counter_Id denotes the entity of the counter.
6496 function Build_Finalization_Call return Node_Id;
6497 -- Generate a deep finalization call for an array element
6499 procedure Build_Indexes;
6500 -- Generate the initialization and finalization indexes used in the
6503 function Build_Initialization_Call return Node_Id;
6504 -- Generate a deep initialization call for an array element
6506 ----------------------
6507 -- Build_Assignment --
6508 ----------------------
6510 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
6515 -- Start from the first dimension and generate:
6520 Make_Attribute_Reference (Loc,
6521 Prefix => Make_Identifier (Loc, Name_V),
6522 Attribute_Name => Name_Length,
6523 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
6525 -- Process the rest of the dimensions, generate:
6526 -- Expr * V'Length (N)
6529 while Dim <= Num_Dims loop
6531 Make_Op_Multiply (Loc,
6534 Make_Attribute_Reference (Loc,
6535 Prefix => Make_Identifier (Loc, Name_V),
6536 Attribute_Name => Name_Length,
6537 Expressions => New_List (
6538 Make_Integer_Literal (Loc, Dim))));
6544 -- Counter := Expr - Counter;
6547 Make_Assignment_Statement (Loc,
6548 Name => New_Occurrence_Of (Counter_Id, Loc),
6550 Make_Op_Subtract (Loc,
6552 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
6553 end Build_Assignment;
6555 -----------------------------
6556 -- Build_Finalization_Call --
6557 -----------------------------
6559 function Build_Finalization_Call return Node_Id is
6560 Comp_Ref : constant Node_Id :=
6561 Make_Indexed_Component (Loc,
6562 Prefix => Make_Identifier (Loc, Name_V),
6563 Expressions => New_References_To (Final_List, Loc));
6566 Set_Etype (Comp_Ref, Comp_Typ);
6569 -- [Deep_]Finalize (V);
6571 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6572 end Build_Finalization_Call;
6578 procedure Build_Indexes is
6580 -- Generate the following identifiers:
6581 -- Jnn - for initialization
6582 -- Fnn - for finalization
6584 for Dim in 1 .. Num_Dims loop
6585 Append_To (Index_List,
6586 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6588 Append_To (Final_List,
6589 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
6593 -------------------------------
6594 -- Build_Initialization_Call --
6595 -------------------------------
6597 function Build_Initialization_Call return Node_Id is
6598 Comp_Ref : constant Node_Id :=
6599 Make_Indexed_Component (Loc,
6600 Prefix => Make_Identifier (Loc, Name_V),
6601 Expressions => New_References_To (Index_List, Loc));
6604 Set_Etype (Comp_Ref, Comp_Typ);
6607 -- [Deep_]Initialize (V (J1, ..., JN));
6609 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6610 end Build_Initialization_Call;
6614 Counter_Id : Entity_Id;
6618 Final_Block : Node_Id;
6619 Final_Data : Finalization_Exception_Data;
6620 Final_Decls : List_Id := No_List;
6621 Final_Loop : Node_Id;
6622 Init_Block : Node_Id;
6623 Init_Call : Node_Id;
6624 Init_Loop : Node_Id;
6629 -- Start of processing for Build_Initialize_Statements
6632 Counter_Id := Make_Temporary (Loc, 'C');
6633 Final_Decls := New_List;
6636 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6638 -- Generate the block which houses the finalization call, the index
6639 -- guard and the handler which triggers Program_Error later on.
6641 -- if Counter > 0 then
6642 -- Counter := Counter - 1;
6645 -- [Deep_]Finalize (V (F1, ..., FN));
6648 -- if not Raised then
6650 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6655 Fin_Stmt := Build_Finalization_Call;
6657 if Present (Fin_Stmt) then
6658 if Exceptions_OK then
6660 Make_Block_Statement (Loc,
6661 Handled_Statement_Sequence =>
6662 Make_Handled_Sequence_Of_Statements (Loc,
6663 Statements => New_List (Fin_Stmt),
6664 Exception_Handlers => New_List (
6665 Build_Exception_Handler (Final_Data))));
6668 -- This is the core of the loop, the dimension iterators are added
6669 -- one by one in reverse.
6672 Make_If_Statement (Loc,
6675 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6676 Right_Opnd => Make_Integer_Literal (Loc, 0)),
6678 Then_Statements => New_List (
6679 Make_Assignment_Statement (Loc,
6680 Name => New_Occurrence_Of (Counter_Id, Loc),
6682 Make_Op_Subtract (Loc,
6683 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6684 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
6686 Else_Statements => New_List (Fin_Stmt));
6688 -- Generate all finalization loops starting from the innermost
6691 -- for Fnn in reverse V'Range (Dim) loop
6695 F := Last (Final_List);
6697 while Present (F) and then Dim > 0 loop
6703 Make_Loop_Statement (Loc,
6705 Make_Iteration_Scheme (Loc,
6706 Loop_Parameter_Specification =>
6707 Make_Loop_Parameter_Specification (Loc,
6708 Defining_Identifier => Loop_Id,
6709 Discrete_Subtype_Definition =>
6710 Make_Attribute_Reference (Loc,
6711 Prefix => Make_Identifier (Loc, Name_V),
6712 Attribute_Name => Name_Range,
6713 Expressions => New_List (
6714 Make_Integer_Literal (Loc, Dim))),
6716 Reverse_Present => True)),
6718 Statements => New_List (Final_Loop),
6719 End_Label => Empty);
6724 -- Generate the block which contains the finalization loops, the
6725 -- declarations of the abort flag, the exception occurrence, the
6726 -- raised flag and the conditional raise.
6729 -- Abort : constant Boolean := Triggered_By_Abort;
6731 -- Abort : constant Boolean := False; -- no abort
6733 -- E : Exception_Occurrence;
6734 -- Raised : Boolean := False;
6740 -- V'Length (N) - Counter;
6744 -- if Raised and then not Abort then
6745 -- Raise_From_Controlled_Operation (E);
6751 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
6753 if Exceptions_OK then
6754 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6755 Append_To (Stmts, Make_Raise_Statement (Loc));
6759 Make_Block_Statement (Loc,
6760 Declarations => Final_Decls,
6761 Handled_Statement_Sequence =>
6762 Make_Handled_Sequence_Of_Statements (Loc,
6763 Statements => Stmts));
6765 -- Otherwise previous errors or a missing full view may prevent the
6766 -- proper freezing of the component type. If this is the case, there
6767 -- is no [Deep_]Finalize primitive to call.
6770 Final_Block := Make_Null_Statement (Loc);
6773 -- Generate the block which contains the initialization call and
6774 -- the partial finalization code.
6777 -- [Deep_]Initialize (V (J1, ..., JN));
6779 -- Counter := Counter + 1;
6783 -- <finalization code>
6786 Init_Call := Build_Initialization_Call;
6788 -- Only create finalization block if there is a non-trivial
6789 -- call to initialization.
6791 if Present (Init_Call)
6792 and then Nkind (Init_Call) /= N_Null_Statement
6795 Make_Block_Statement (Loc,
6796 Handled_Statement_Sequence =>
6797 Make_Handled_Sequence_Of_Statements (Loc,
6798 Statements => New_List (Init_Call),
6799 Exception_Handlers => New_List (
6800 Make_Exception_Handler (Loc,
6801 Exception_Choices => New_List (
6802 Make_Others_Choice (Loc)),
6803 Statements => New_List (Final_Block)))));
6805 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
6806 Make_Assignment_Statement (Loc,
6807 Name => New_Occurrence_Of (Counter_Id, Loc),
6810 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6811 Right_Opnd => Make_Integer_Literal (Loc, 1))));
6813 -- Generate all initialization loops starting from the innermost
6816 -- for Jnn in V'Range (Dim) loop
6820 J := Last (Index_List);
6822 while Present (J) and then Dim > 0 loop
6828 Make_Loop_Statement (Loc,
6830 Make_Iteration_Scheme (Loc,
6831 Loop_Parameter_Specification =>
6832 Make_Loop_Parameter_Specification (Loc,
6833 Defining_Identifier => Loop_Id,
6834 Discrete_Subtype_Definition =>
6835 Make_Attribute_Reference (Loc,
6836 Prefix => Make_Identifier (Loc, Name_V),
6837 Attribute_Name => Name_Range,
6838 Expressions => New_List (
6839 Make_Integer_Literal (Loc, Dim))))),
6841 Statements => New_List (Init_Loop),
6842 End_Label => Empty);
6847 -- Generate the block which contains the counter variable and the
6848 -- initialization loops.
6851 -- Counter : Integer := 0;
6857 Make_Block_Statement (Loc,
6858 Declarations => New_List (
6859 Make_Object_Declaration (Loc,
6860 Defining_Identifier => Counter_Id,
6861 Object_Definition =>
6862 New_Occurrence_Of (Standard_Integer, Loc),
6863 Expression => Make_Integer_Literal (Loc, 0))),
6865 Handled_Statement_Sequence =>
6866 Make_Handled_Sequence_Of_Statements (Loc,
6867 Statements => New_List (Init_Loop)));
6869 -- Otherwise previous errors or a missing full view may prevent the
6870 -- proper freezing of the component type. If this is the case, there
6871 -- is no [Deep_]Initialize primitive to call.
6874 Init_Block := Make_Null_Statement (Loc);
6877 return New_List (Init_Block);
6878 end Build_Initialize_Statements;
6880 -----------------------
6881 -- New_References_To --
6882 -----------------------
6884 function New_References_To
6886 Loc : Source_Ptr) return List_Id
6888 Refs : constant List_Id := New_List;
6893 while Present (Id) loop
6894 Append_To (Refs, New_Occurrence_Of (Id, Loc));
6899 end New_References_To;
6901 -- Start of processing for Make_Deep_Array_Body
6905 when Address_Case =>
6906 return Make_Finalize_Address_Stmts (Typ);
6911 return Build_Adjust_Or_Finalize_Statements (Typ);
6913 when Initialize_Case =>
6914 return Build_Initialize_Statements (Typ);
6916 end Make_Deep_Array_Body;
6918 --------------------
6919 -- Make_Deep_Proc --
6920 --------------------
6922 function Make_Deep_Proc
6923 (Prim : Final_Primitives;
6925 Stmts : List_Id) return Entity_Id
6927 Loc : constant Source_Ptr := Sloc (Typ);
6929 Proc_Id : Entity_Id;
6932 -- Create the object formal, generate:
6933 -- V : System.Address
6935 if Prim = Address_Case then
6936 Formals := New_List (
6937 Make_Parameter_Specification (Loc,
6938 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6940 New_Occurrence_Of (RTE (RE_Address), Loc)));
6947 Formals := New_List (
6948 Make_Parameter_Specification (Loc,
6949 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6951 Out_Present => True,
6952 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
6954 -- F : Boolean := True
6956 if Prim = Adjust_Case
6957 or else Prim = Finalize_Case
6960 Make_Parameter_Specification (Loc,
6961 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
6963 New_Occurrence_Of (Standard_Boolean, Loc),
6965 New_Occurrence_Of (Standard_True, Loc)));
6970 Make_Defining_Identifier (Loc,
6971 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
6974 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6977 -- exception -- Finalize and Adjust cases only
6978 -- raise Program_Error;
6979 -- end Deep_Initialize / Adjust / Finalize;
6983 -- procedure Finalize_Address (V : System.Address) is
6986 -- end Finalize_Address;
6989 Make_Subprogram_Body (Loc,
6991 Make_Procedure_Specification (Loc,
6992 Defining_Unit_Name => Proc_Id,
6993 Parameter_Specifications => Formals),
6995 Declarations => Empty_List,
6997 Handled_Statement_Sequence =>
6998 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
7000 -- If there are no calls to component initialization, indicate that
7001 -- the procedure is trivial, so prevent calls to it.
7003 if Is_Empty_List (Stmts)
7004 or else Nkind (First (Stmts)) = N_Null_Statement
7006 Set_Is_Trivial_Subprogram (Proc_Id);
7012 ---------------------------
7013 -- Make_Deep_Record_Body --
7014 ---------------------------
7016 function Make_Deep_Record_Body
7017 (Prim : Final_Primitives;
7019 Is_Local : Boolean := False) return List_Id
7021 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
7022 -- Build the statements necessary to adjust a record type. The type may
7023 -- have discriminants and contain variant parts. Generate:
7027 -- [Deep_]Adjust (V.Comp_1);
7029 -- when Id : others =>
7030 -- if not Raised then
7032 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7037 -- [Deep_]Adjust (V.Comp_N);
7039 -- when Id : others =>
7040 -- if not Raised then
7042 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7047 -- Deep_Adjust (V._parent, False); -- If applicable
7049 -- when Id : others =>
7050 -- if not Raised then
7052 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7058 -- Adjust (V); -- If applicable
7061 -- if not Raised then
7063 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7068 -- if Raised and then not Abort then
7069 -- Raise_From_Controlled_Operation (E);
7073 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
7074 -- Build the statements necessary to finalize a record type. The type
7075 -- may have discriminants and contain variant parts. Generate:
7078 -- Abort : constant Boolean := Triggered_By_Abort;
7080 -- Abort : constant Boolean := False; -- no abort
7081 -- E : Exception_Occurrence;
7082 -- Raised : Boolean := False;
7087 -- Finalize (V); -- If applicable
7090 -- if not Raised then
7092 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7097 -- case Variant_1 is
7099 -- case State_Counter_N => -- If Is_Local is enabled
7109 -- <<LN>> -- If Is_Local is enabled
7111 -- [Deep_]Finalize (V.Comp_N);
7114 -- if not Raised then
7116 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7122 -- [Deep_]Finalize (V.Comp_1);
7125 -- if not Raised then
7127 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7133 -- case State_Counter_1 => -- If Is_Local is enabled
7139 -- Deep_Finalize (V._parent, False); -- If applicable
7141 -- when Id : others =>
7142 -- if not Raised then
7144 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7148 -- if Raised and then not Abort then
7149 -- Raise_From_Controlled_Operation (E);
7153 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
7154 -- Given a derived tagged type Typ, traverse all components, find field
7155 -- _parent and return its type.
7157 procedure Preprocess_Components
7159 Num_Comps : out Nat;
7160 Has_POC : out Boolean);
7161 -- Examine all components in component list Comps, count all controlled
7162 -- components and determine whether at least one of them is per-object
7163 -- constrained. Component _parent is always skipped.
7165 -----------------------------
7166 -- Build_Adjust_Statements --
7167 -----------------------------
7169 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
7170 Loc : constant Source_Ptr := Sloc (Typ);
7171 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7173 Finalizer_Data : Finalization_Exception_Data;
7175 function Process_Component_List_For_Adjust
7176 (Comps : Node_Id) return List_Id;
7177 -- Build all necessary adjust statements for a single component list
7179 ---------------------------------------
7180 -- Process_Component_List_For_Adjust --
7181 ---------------------------------------
7183 function Process_Component_List_For_Adjust
7184 (Comps : Node_Id) return List_Id
7186 Stmts : constant List_Id := New_List;
7188 procedure Process_Component_For_Adjust (Decl : Node_Id);
7189 -- Process the declaration of a single controlled component
7191 ----------------------------------
7192 -- Process_Component_For_Adjust --
7193 ----------------------------------
7195 procedure Process_Component_For_Adjust (Decl : Node_Id) is
7196 Id : constant Entity_Id := Defining_Identifier (Decl);
7197 Typ : constant Entity_Id := Etype (Id);
7203 -- [Deep_]Adjust (V.Id);
7207 -- if not Raised then
7209 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7216 Make_Selected_Component (Loc,
7217 Prefix => Make_Identifier (Loc, Name_V),
7218 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7221 -- Guard against a missing [Deep_]Adjust when the component
7222 -- type was not properly frozen.
7224 if Present (Adj_Call) then
7225 if Exceptions_OK then
7227 Make_Block_Statement (Loc,
7228 Handled_Statement_Sequence =>
7229 Make_Handled_Sequence_Of_Statements (Loc,
7230 Statements => New_List (Adj_Call),
7231 Exception_Handlers => New_List (
7232 Build_Exception_Handler (Finalizer_Data))));
7235 Append_To (Stmts, Adj_Call);
7237 end Process_Component_For_Adjust;
7242 Decl_Id : Entity_Id;
7243 Decl_Typ : Entity_Id;
7248 -- Start of processing for Process_Component_List_For_Adjust
7251 -- Perform an initial check, determine the number of controlled
7252 -- components in the current list and whether at least one of them
7253 -- is per-object constrained.
7255 Preprocess_Components (Comps, Num_Comps, Has_POC);
7257 -- The processing in this routine is done in the following order:
7258 -- 1) Regular components
7259 -- 2) Per-object constrained components
7262 if Num_Comps > 0 then
7264 -- Process all regular components in order of declarations
7266 Decl := First_Non_Pragma (Component_Items (Comps));
7267 while Present (Decl) loop
7268 Decl_Id := Defining_Identifier (Decl);
7269 Decl_Typ := Etype (Decl_Id);
7271 -- Skip _parent as well as per-object constrained components
7273 if Chars (Decl_Id) /= Name_uParent
7274 and then Needs_Finalization (Decl_Typ)
7276 if Has_Access_Constraint (Decl_Id)
7277 and then No (Expression (Decl))
7281 Process_Component_For_Adjust (Decl);
7285 Next_Non_Pragma (Decl);
7288 -- Process all per-object constrained components in order of
7292 Decl := First_Non_Pragma (Component_Items (Comps));
7293 while Present (Decl) loop
7294 Decl_Id := Defining_Identifier (Decl);
7295 Decl_Typ := Etype (Decl_Id);
7299 if Chars (Decl_Id) /= Name_uParent
7300 and then Needs_Finalization (Decl_Typ)
7301 and then Has_Access_Constraint (Decl_Id)
7302 and then No (Expression (Decl))
7304 Process_Component_For_Adjust (Decl);
7307 Next_Non_Pragma (Decl);
7312 -- Process all variants, if any
7315 if Present (Variant_Part (Comps)) then
7317 Var_Alts : constant List_Id := New_List;
7321 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7322 while Present (Var) loop
7325 -- when <discrete choices> =>
7326 -- <adjust statements>
7328 Append_To (Var_Alts,
7329 Make_Case_Statement_Alternative (Loc,
7331 New_Copy_List (Discrete_Choices (Var)),
7333 Process_Component_List_For_Adjust (
7334 Component_List (Var))));
7336 Next_Non_Pragma (Var);
7340 -- case V.<discriminant> is
7341 -- when <discrete choices 1> =>
7342 -- <adjust statements 1>
7344 -- when <discrete choices N> =>
7345 -- <adjust statements N>
7349 Make_Case_Statement (Loc,
7351 Make_Selected_Component (Loc,
7352 Prefix => Make_Identifier (Loc, Name_V),
7354 Make_Identifier (Loc,
7355 Chars => Chars (Name (Variant_Part (Comps))))),
7356 Alternatives => Var_Alts);
7360 -- Add the variant case statement to the list of statements
7362 if Present (Var_Case) then
7363 Append_To (Stmts, Var_Case);
7366 -- If the component list did not have any controlled components
7367 -- nor variants, return null.
7369 if Is_Empty_List (Stmts) then
7370 Append_To (Stmts, Make_Null_Statement (Loc));
7374 end Process_Component_List_For_Adjust;
7378 Bod_Stmts : List_Id := No_List;
7379 Finalizer_Decls : List_Id := No_List;
7382 -- Start of processing for Build_Adjust_Statements
7385 Finalizer_Decls := New_List;
7386 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7388 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7389 Rec_Def := Record_Extension_Part (Typ_Def);
7394 -- Create an adjust sequence for all record components
7396 if Present (Component_List (Rec_Def)) then
7398 Process_Component_List_For_Adjust (Component_List (Rec_Def));
7401 -- A derived record type must adjust all inherited components. This
7402 -- action poses the following problem:
7404 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7409 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7411 -- Deep_Adjust (Obj._parent);
7416 -- Adjusting the derived type will invoke Adjust of the parent and
7417 -- then that of the derived type. This is undesirable because both
7418 -- routines may modify shared components. Only the Adjust of the
7419 -- derived type should be invoked.
7421 -- To prevent this double adjustment of shared components,
7422 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7424 -- procedure Deep_Adjust
7425 -- (Obj : in out Some_Type;
7426 -- Flag : Boolean := True)
7434 -- When Deep_Adjust is invokes for field _parent, a value of False is
7435 -- provided for the flag:
7437 -- Deep_Adjust (Obj._parent, False);
7439 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7441 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7446 if Needs_Finalization (Par_Typ) then
7450 Make_Selected_Component (Loc,
7451 Prefix => Make_Identifier (Loc, Name_V),
7453 Make_Identifier (Loc, Name_uParent)),
7459 -- Deep_Adjust (V._parent, False);
7462 -- when Id : others =>
7463 -- if not Raised then
7465 -- Save_Occurrence (E,
7466 -- Get_Current_Excep.all.all);
7470 if Present (Call) then
7473 if Exceptions_OK then
7475 Make_Block_Statement (Loc,
7476 Handled_Statement_Sequence =>
7477 Make_Handled_Sequence_Of_Statements (Loc,
7478 Statements => New_List (Adj_Stmt),
7479 Exception_Handlers => New_List (
7480 Build_Exception_Handler (Finalizer_Data))));
7483 Prepend_To (Bod_Stmts, Adj_Stmt);
7489 -- Adjust the object. This action must be performed last after all
7490 -- components have been adjusted.
7492 if Is_Controlled (Typ) then
7498 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
7507 -- if not Raised then
7509 -- Save_Occurrence (E,
7510 -- Get_Current_Excep.all.all);
7515 if Present (Proc) then
7517 Make_Procedure_Call_Statement (Loc,
7518 Name => New_Occurrence_Of (Proc, Loc),
7519 Parameter_Associations => New_List (
7520 Make_Identifier (Loc, Name_V)));
7522 if Exceptions_OK then
7524 Make_Block_Statement (Loc,
7525 Handled_Statement_Sequence =>
7526 Make_Handled_Sequence_Of_Statements (Loc,
7527 Statements => New_List (Adj_Stmt),
7528 Exception_Handlers => New_List (
7529 Build_Exception_Handler
7530 (Finalizer_Data))));
7533 Append_To (Bod_Stmts,
7534 Make_If_Statement (Loc,
7535 Condition => Make_Identifier (Loc, Name_F),
7536 Then_Statements => New_List (Adj_Stmt)));
7541 -- At this point either all adjustment statements have been generated
7542 -- or the type is not controlled.
7544 if Is_Empty_List (Bod_Stmts) then
7545 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
7551 -- Abort : constant Boolean := Triggered_By_Abort;
7553 -- Abort : constant Boolean := False; -- no abort
7555 -- E : Exception_Occurrence;
7556 -- Raised : Boolean := False;
7559 -- <adjust statements>
7561 -- if Raised and then not Abort then
7562 -- Raise_From_Controlled_Operation (E);
7567 if Exceptions_OK then
7568 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7573 Make_Block_Statement (Loc,
7576 Handled_Statement_Sequence =>
7577 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7579 end Build_Adjust_Statements;
7581 -------------------------------
7582 -- Build_Finalize_Statements --
7583 -------------------------------
7585 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
7586 Loc : constant Source_Ptr := Sloc (Typ);
7587 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7590 Finalizer_Data : Finalization_Exception_Data;
7592 function Process_Component_List_For_Finalize
7593 (Comps : Node_Id) return List_Id;
7594 -- Build all necessary finalization statements for a single component
7595 -- list. The statements may include a jump circuitry if flag Is_Local
7598 -----------------------------------------
7599 -- Process_Component_List_For_Finalize --
7600 -----------------------------------------
7602 function Process_Component_List_For_Finalize
7603 (Comps : Node_Id) return List_Id
7605 procedure Process_Component_For_Finalize
7610 Num_Comps : in out Nat);
7611 -- Process the declaration of a single controlled component. If
7612 -- flag Is_Local is enabled, create the corresponding label and
7613 -- jump circuitry. Alts is the list of case alternatives, Decls
7614 -- is the top level declaration list where labels are declared
7615 -- and Stmts is the list of finalization actions. Num_Comps
7616 -- denotes the current number of components needing finalization.
7618 ------------------------------------
7619 -- Process_Component_For_Finalize --
7620 ------------------------------------
7622 procedure Process_Component_For_Finalize
7627 Num_Comps : in out Nat)
7629 Id : constant Entity_Id := Defining_Identifier (Decl);
7630 Typ : constant Entity_Id := Etype (Id);
7637 Label_Id : Entity_Id;
7644 Make_Identifier (Loc,
7645 Chars => New_External_Name ('L', Num_Comps));
7646 Set_Entity (Label_Id,
7647 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7648 Label := Make_Label (Loc, Label_Id);
7651 Make_Implicit_Label_Declaration (Loc,
7652 Defining_Identifier => Entity (Label_Id),
7653 Label_Construct => Label));
7660 Make_Case_Statement_Alternative (Loc,
7661 Discrete_Choices => New_List (
7662 Make_Integer_Literal (Loc, Num_Comps)),
7664 Statements => New_List (
7665 Make_Goto_Statement (Loc,
7667 New_Occurrence_Of (Entity (Label_Id), Loc)))));
7672 Append_To (Stmts, Label);
7674 -- Decrease the number of components to be processed.
7675 -- This action yields a new Label_Id in future calls.
7677 Num_Comps := Num_Comps - 1;
7682 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7684 -- begin -- Exception handlers allowed
7685 -- [Deep_]Finalize (V.Id);
7688 -- if not Raised then
7690 -- Save_Occurrence (E,
7691 -- Get_Current_Excep.all.all);
7698 Make_Selected_Component (Loc,
7699 Prefix => Make_Identifier (Loc, Name_V),
7700 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7703 -- Guard against a missing [Deep_]Finalize when the component
7704 -- type was not properly frozen.
7706 if Present (Fin_Call) then
7707 if Exceptions_OK then
7709 Make_Block_Statement (Loc,
7710 Handled_Statement_Sequence =>
7711 Make_Handled_Sequence_Of_Statements (Loc,
7712 Statements => New_List (Fin_Call),
7713 Exception_Handlers => New_List (
7714 Build_Exception_Handler (Finalizer_Data))));
7717 Append_To (Stmts, Fin_Call);
7719 end Process_Component_For_Finalize;
7724 Counter_Id : Entity_Id := Empty;
7726 Decl_Id : Entity_Id;
7727 Decl_Typ : Entity_Id;
7730 Jump_Block : Node_Id;
7732 Label_Id : Entity_Id;
7737 -- Start of processing for Process_Component_List_For_Finalize
7740 -- Perform an initial check, look for controlled and per-object
7741 -- constrained components.
7743 Preprocess_Components (Comps, Num_Comps, Has_POC);
7745 -- Create a state counter to service the current component list.
7746 -- This step is performed before the variants are inspected in
7747 -- order to generate the same state counter names as those from
7748 -- Build_Initialize_Statements.
7750 if Num_Comps > 0 and then Is_Local then
7751 Counter := Counter + 1;
7754 Make_Defining_Identifier (Loc,
7755 Chars => New_External_Name ('C', Counter));
7758 -- Process the component in the following order:
7760 -- 2) Per-object constrained components
7761 -- 3) Regular components
7763 -- Start with the variant parts
7766 if Present (Variant_Part (Comps)) then
7768 Var_Alts : constant List_Id := New_List;
7772 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7773 while Present (Var) loop
7776 -- when <discrete choices> =>
7777 -- <finalize statements>
7779 Append_To (Var_Alts,
7780 Make_Case_Statement_Alternative (Loc,
7782 New_Copy_List (Discrete_Choices (Var)),
7784 Process_Component_List_For_Finalize (
7785 Component_List (Var))));
7787 Next_Non_Pragma (Var);
7791 -- case V.<discriminant> is
7792 -- when <discrete choices 1> =>
7793 -- <finalize statements 1>
7795 -- when <discrete choices N> =>
7796 -- <finalize statements N>
7800 Make_Case_Statement (Loc,
7802 Make_Selected_Component (Loc,
7803 Prefix => Make_Identifier (Loc, Name_V),
7805 Make_Identifier (Loc,
7806 Chars => Chars (Name (Variant_Part (Comps))))),
7807 Alternatives => Var_Alts);
7811 -- The current component list does not have a single controlled
7812 -- component, however it may contain variants. Return the case
7813 -- statement for the variants or nothing.
7815 if Num_Comps = 0 then
7816 if Present (Var_Case) then
7817 return New_List (Var_Case);
7819 return New_List (Make_Null_Statement (Loc));
7823 -- Prepare all lists
7829 -- Process all per-object constrained components in reverse order
7832 Decl := Last_Non_Pragma (Component_Items (Comps));
7833 while Present (Decl) loop
7834 Decl_Id := Defining_Identifier (Decl);
7835 Decl_Typ := Etype (Decl_Id);
7839 if Chars (Decl_Id) /= Name_uParent
7840 and then Needs_Finalization (Decl_Typ)
7841 and then Has_Access_Constraint (Decl_Id)
7842 and then No (Expression (Decl))
7844 Process_Component_For_Finalize
7845 (Decl, Alts, Decls, Stmts, Num_Comps);
7848 Prev_Non_Pragma (Decl);
7852 -- Process the rest of the components in reverse order
7854 Decl := Last_Non_Pragma (Component_Items (Comps));
7855 while Present (Decl) loop
7856 Decl_Id := Defining_Identifier (Decl);
7857 Decl_Typ := Etype (Decl_Id);
7861 if Chars (Decl_Id) /= Name_uParent
7862 and then Needs_Finalization (Decl_Typ)
7864 -- Skip per-object constrained components since they were
7865 -- handled in the above step.
7867 if Has_Access_Constraint (Decl_Id)
7868 and then No (Expression (Decl))
7872 Process_Component_For_Finalize
7873 (Decl, Alts, Decls, Stmts, Num_Comps);
7877 Prev_Non_Pragma (Decl);
7882 -- LN : label; -- If Is_Local is enabled
7887 -- case CounterX is .
7897 -- <<LN>> -- If Is_Local is enabled
7899 -- [Deep_]Finalize (V.CompY);
7901 -- when Id : others =>
7902 -- if not Raised then
7904 -- Save_Occurrence (E,
7905 -- Get_Current_Excep.all.all);
7909 -- <<L0>> -- If Is_Local is enabled
7914 -- Add the declaration of default jump location L0, its
7915 -- corresponding alternative and its place in the statements.
7917 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
7918 Set_Entity (Label_Id,
7919 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7920 Label := Make_Label (Loc, Label_Id);
7922 Append_To (Decls, -- declaration
7923 Make_Implicit_Label_Declaration (Loc,
7924 Defining_Identifier => Entity (Label_Id),
7925 Label_Construct => Label));
7927 Append_To (Alts, -- alternative
7928 Make_Case_Statement_Alternative (Loc,
7929 Discrete_Choices => New_List (
7930 Make_Others_Choice (Loc)),
7932 Statements => New_List (
7933 Make_Goto_Statement (Loc,
7934 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
7936 Append_To (Stmts, Label); -- statement
7938 -- Create the jump block
7941 Make_Case_Statement (Loc,
7942 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
7943 Alternatives => Alts));
7947 Make_Block_Statement (Loc,
7948 Declarations => Decls,
7949 Handled_Statement_Sequence =>
7950 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7952 if Present (Var_Case) then
7953 return New_List (Var_Case, Jump_Block);
7955 return New_List (Jump_Block);
7957 end Process_Component_List_For_Finalize;
7961 Bod_Stmts : List_Id := No_List;
7962 Finalizer_Decls : List_Id := No_List;
7965 -- Start of processing for Build_Finalize_Statements
7968 Finalizer_Decls := New_List;
7969 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7971 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7972 Rec_Def := Record_Extension_Part (Typ_Def);
7977 -- Create a finalization sequence for all record components
7979 if Present (Component_List (Rec_Def)) then
7981 Process_Component_List_For_Finalize (Component_List (Rec_Def));
7984 -- A derived record type must finalize all inherited components. This
7985 -- action poses the following problem:
7987 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7992 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7994 -- Deep_Finalize (Obj._parent);
7999 -- Finalizing the derived type will invoke Finalize of the parent and
8000 -- then that of the derived type. This is undesirable because both
8001 -- routines may modify shared components. Only the Finalize of the
8002 -- derived type should be invoked.
8004 -- To prevent this double adjustment of shared components,
8005 -- Deep_Finalize uses a flag to control the invocation of Finalize:
8007 -- procedure Deep_Finalize
8008 -- (Obj : in out Some_Type;
8009 -- Flag : Boolean := True)
8017 -- When Deep_Finalize is invoked for field _parent, a value of False
8018 -- is provided for the flag:
8020 -- Deep_Finalize (Obj._parent, False);
8022 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8024 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8029 if Needs_Finalization (Par_Typ) then
8033 Make_Selected_Component (Loc,
8034 Prefix => Make_Identifier (Loc, Name_V),
8036 Make_Identifier (Loc, Name_uParent)),
8042 -- Deep_Finalize (V._parent, False);
8045 -- when Id : others =>
8046 -- if not Raised then
8048 -- Save_Occurrence (E,
8049 -- Get_Current_Excep.all.all);
8053 if Present (Call) then
8056 if Exceptions_OK then
8058 Make_Block_Statement (Loc,
8059 Handled_Statement_Sequence =>
8060 Make_Handled_Sequence_Of_Statements (Loc,
8061 Statements => New_List (Fin_Stmt),
8062 Exception_Handlers => New_List (
8063 Build_Exception_Handler
8064 (Finalizer_Data))));
8067 Append_To (Bod_Stmts, Fin_Stmt);
8073 -- Finalize the object. This action must be performed first before
8074 -- all components have been finalized.
8076 if Is_Controlled (Typ) and then not Is_Local then
8082 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
8091 -- if not Raised then
8093 -- Save_Occurrence (E,
8094 -- Get_Current_Excep.all.all);
8099 if Present (Proc) then
8101 Make_Procedure_Call_Statement (Loc,
8102 Name => New_Occurrence_Of (Proc, Loc),
8103 Parameter_Associations => New_List (
8104 Make_Identifier (Loc, Name_V)));
8106 if Exceptions_OK then
8108 Make_Block_Statement (Loc,
8109 Handled_Statement_Sequence =>
8110 Make_Handled_Sequence_Of_Statements (Loc,
8111 Statements => New_List (Fin_Stmt),
8112 Exception_Handlers => New_List (
8113 Build_Exception_Handler
8114 (Finalizer_Data))));
8117 Prepend_To (Bod_Stmts,
8118 Make_If_Statement (Loc,
8119 Condition => Make_Identifier (Loc, Name_F),
8120 Then_Statements => New_List (Fin_Stmt)));
8125 -- At this point either all finalization statements have been
8126 -- generated or the type is not controlled.
8128 if No (Bod_Stmts) then
8129 return New_List (Make_Null_Statement (Loc));
8133 -- Abort : constant Boolean := Triggered_By_Abort;
8135 -- Abort : constant Boolean := False; -- no abort
8137 -- E : Exception_Occurrence;
8138 -- Raised : Boolean := False;
8141 -- <finalize statements>
8143 -- if Raised and then not Abort then
8144 -- Raise_From_Controlled_Operation (E);
8149 if Exceptions_OK then
8150 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8155 Make_Block_Statement (Loc,
8158 Handled_Statement_Sequence =>
8159 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8161 end Build_Finalize_Statements;
8163 -----------------------
8164 -- Parent_Field_Type --
8165 -----------------------
8167 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
8171 Field := First_Entity (Typ);
8172 while Present (Field) loop
8173 if Chars (Field) = Name_uParent then
8174 return Etype (Field);
8177 Next_Entity (Field);
8180 -- A derived tagged type should always have a parent field
8182 raise Program_Error;
8183 end Parent_Field_Type;
8185 ---------------------------
8186 -- Preprocess_Components --
8187 ---------------------------
8189 procedure Preprocess_Components
8191 Num_Comps : out Nat;
8192 Has_POC : out Boolean)
8202 Decl := First_Non_Pragma (Component_Items (Comps));
8203 while Present (Decl) loop
8204 Id := Defining_Identifier (Decl);
8207 -- Skip field _parent
8209 if Chars (Id) /= Name_uParent
8210 and then Needs_Finalization (Typ)
8212 Num_Comps := Num_Comps + 1;
8214 if Has_Access_Constraint (Id)
8215 and then No (Expression (Decl))
8221 Next_Non_Pragma (Decl);
8223 end Preprocess_Components;
8225 -- Start of processing for Make_Deep_Record_Body
8229 when Address_Case =>
8230 return Make_Finalize_Address_Stmts (Typ);
8233 return Build_Adjust_Statements (Typ);
8235 when Finalize_Case =>
8236 return Build_Finalize_Statements (Typ);
8238 when Initialize_Case =>
8240 Loc : constant Source_Ptr := Sloc (Typ);
8243 if Is_Controlled (Typ) then
8245 Make_Procedure_Call_Statement (Loc,
8248 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
8249 Parameter_Associations => New_List (
8250 Make_Identifier (Loc, Name_V))));
8256 end Make_Deep_Record_Body;
8258 ----------------------
8259 -- Make_Final_Call --
8260 ----------------------
8262 function Make_Final_Call
8265 Skip_Self : Boolean := False) return Node_Id
8267 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8269 Fin_Id : Entity_Id := Empty;
8276 -- Recover the proper type which contains [Deep_]Finalize
8278 if Is_Class_Wide_Type (Typ) then
8279 Utyp := Root_Type (Typ);
8282 elsif Is_Concurrent_Type (Typ) then
8283 Utyp := Corresponding_Record_Type (Typ);
8285 Ref := Convert_Concurrent (Ref, Typ);
8287 elsif Is_Private_Type (Typ)
8288 and then Present (Full_View (Typ))
8289 and then Is_Concurrent_Type (Full_View (Typ))
8291 Utyp := Corresponding_Record_Type (Full_View (Typ));
8293 Ref := Convert_Concurrent (Ref, Full_View (Typ));
8300 Utyp := Underlying_Type (Base_Type (Utyp));
8301 Set_Assignment_OK (Ref);
8303 -- Deal with untagged derivation of private views. If the parent type
8304 -- is a protected type, Deep_Finalize is found on the corresponding
8305 -- record of the ancestor.
8307 if Is_Untagged_Derivation (Typ) then
8308 if Is_Protected_Type (Typ) then
8309 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
8311 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8313 if Is_Protected_Type (Utyp) then
8314 Utyp := Corresponding_Record_Type (Utyp);
8318 Ref := Unchecked_Convert_To (Utyp, Ref);
8319 Set_Assignment_OK (Ref);
8322 -- Deal with derived private types which do not inherit primitives from
8323 -- their parents. In this case, [Deep_]Finalize can be found in the full
8324 -- view of the parent type.
8327 and then Is_Tagged_Type (Utyp)
8328 and then Is_Derived_Type (Utyp)
8329 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
8330 and then Is_Private_Type (Etype (Utyp))
8331 and then Present (Full_View (Etype (Utyp)))
8333 Utyp := Full_View (Etype (Utyp));
8334 Ref := Unchecked_Convert_To (Utyp, Ref);
8335 Set_Assignment_OK (Ref);
8338 -- When dealing with the completion of a private type, use the base type
8341 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8342 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
8344 Utyp := Base_Type (Utyp);
8345 Ref := Unchecked_Convert_To (Utyp, Ref);
8346 Set_Assignment_OK (Ref);
8349 -- The underlying type may not be present due to a missing full view. In
8350 -- this case freezing did not take place and there is no [Deep_]Finalize
8351 -- primitive to call.
8356 elsif Skip_Self then
8357 if Has_Controlled_Component (Utyp) then
8358 if Is_Tagged_Type (Utyp) then
8359 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8361 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8365 -- Class-wide types, interfaces and types with controlled components
8367 elsif Is_Class_Wide_Type (Typ)
8368 or else Is_Interface (Typ)
8369 or else Has_Controlled_Component (Utyp)
8371 if Is_Tagged_Type (Utyp) then
8372 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8374 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8377 -- Derivations from [Limited_]Controlled
8379 elsif Is_Controlled (Utyp) then
8380 if Has_Controlled_Component (Utyp) then
8381 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8383 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
8388 elsif Is_Tagged_Type (Utyp) then
8389 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8392 raise Program_Error;
8395 if Present (Fin_Id) then
8397 -- When finalizing a class-wide object, do not convert to the root
8398 -- type in order to produce a dispatching call.
8400 if Is_Class_Wide_Type (Typ) then
8403 -- Ensure that a finalization routine is at least decorated in order
8404 -- to inspect the object parameter.
8406 elsif Analyzed (Fin_Id)
8407 or else Ekind (Fin_Id) = E_Procedure
8409 -- In certain cases, such as the creation of Stream_Read, the
8410 -- visible entity of the type is its full view. Since Stream_Read
8411 -- will have to create an object of type Typ, the local object
8412 -- will be finalzed by the scope finalizer generated later on. The
8413 -- object parameter of Deep_Finalize will always use the private
8414 -- view of the type. To avoid such a clash between a private and a
8415 -- full view, perform an unchecked conversion of the object
8416 -- reference to the private view.
8419 Formal_Typ : constant Entity_Id :=
8420 Etype (First_Formal (Fin_Id));
8422 if Is_Private_Type (Formal_Typ)
8423 and then Present (Full_View (Formal_Typ))
8424 and then Full_View (Formal_Typ) = Utyp
8426 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
8430 Ref := Convert_View (Fin_Id, Ref);
8437 Skip_Self => Skip_Self);
8441 end Make_Final_Call;
8443 --------------------------------
8444 -- Make_Finalize_Address_Body --
8445 --------------------------------
8447 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
8448 Is_Task : constant Boolean :=
8449 Ekind (Typ) = E_Record_Type
8450 and then Is_Concurrent_Record_Type (Typ)
8451 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
8453 Loc : constant Source_Ptr := Sloc (Typ);
8454 Proc_Id : Entity_Id;
8458 -- The corresponding records of task types are not controlled by design.
8459 -- For the sake of completeness, create an empty Finalize_Address to be
8460 -- used in task class-wide allocations.
8465 -- Nothing to do if the type is not controlled or it already has a
8466 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8467 -- come from source. These are usually generated for completeness and
8468 -- do not need the Finalize_Address primitive.
8470 elsif not Needs_Finalization (Typ)
8471 or else Present (TSS (Typ, TSS_Finalize_Address))
8473 (Is_Class_Wide_Type (Typ)
8474 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
8475 and then not Comes_From_Source (Root_Type (Typ)))
8480 -- Do not generate Finalize_Address routine for CodePeer
8482 if CodePeer_Mode then
8487 Make_Defining_Identifier (Loc,
8488 Make_TSS_Name (Typ, TSS_Finalize_Address));
8492 -- procedure <Typ>FD (V : System.Address) is
8494 -- null; -- for tasks
8496 -- declare -- for all other types
8497 -- type Pnn is access all Typ;
8498 -- for Pnn'Storage_Size use 0;
8500 -- [Deep_]Finalize (Pnn (V).all);
8505 Stmts := New_List (Make_Null_Statement (Loc));
8507 Stmts := Make_Finalize_Address_Stmts (Typ);
8511 Make_Subprogram_Body (Loc,
8513 Make_Procedure_Specification (Loc,
8514 Defining_Unit_Name => Proc_Id,
8516 Parameter_Specifications => New_List (
8517 Make_Parameter_Specification (Loc,
8518 Defining_Identifier =>
8519 Make_Defining_Identifier (Loc, Name_V),
8521 New_Occurrence_Of (RTE (RE_Address), Loc)))),
8523 Declarations => No_List,
8525 Handled_Statement_Sequence =>
8526 Make_Handled_Sequence_Of_Statements (Loc,
8527 Statements => Stmts)));
8529 Set_TSS (Typ, Proc_Id);
8530 end Make_Finalize_Address_Body;
8532 ---------------------------------
8533 -- Make_Finalize_Address_Stmts --
8534 ---------------------------------
8536 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
8537 Loc : constant Source_Ptr := Sloc (Typ);
8540 Desig_Typ : Entity_Id;
8541 Fin_Block : Node_Id;
8544 Ptr_Typ : Entity_Id;
8547 if Is_Array_Type (Typ) then
8548 if Is_Constrained (First_Subtype (Typ)) then
8549 Desig_Typ := First_Subtype (Typ);
8551 Desig_Typ := Base_Type (Typ);
8554 -- Class-wide types of constrained root types
8556 elsif Is_Class_Wide_Type (Typ)
8557 and then Has_Discriminants (Root_Type (Typ))
8559 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
8562 Parent_Typ : Entity_Id;
8565 -- Climb the parent type chain looking for a non-constrained type
8567 Parent_Typ := Root_Type (Typ);
8568 while Parent_Typ /= Etype (Parent_Typ)
8569 and then Has_Discriminants (Parent_Typ)
8571 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
8573 Parent_Typ := Etype (Parent_Typ);
8576 -- Handle views created for tagged types with unknown
8579 if Is_Underlying_Record_View (Parent_Typ) then
8580 Parent_Typ := Underlying_Record_View (Parent_Typ);
8583 Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
8593 -- type Ptr_Typ is access all Typ;
8594 -- for Ptr_Typ'Storage_Size use 0;
8596 Ptr_Typ := Make_Temporary (Loc, 'P');
8599 Make_Full_Type_Declaration (Loc,
8600 Defining_Identifier => Ptr_Typ,
8602 Make_Access_To_Object_Definition (Loc,
8603 All_Present => True,
8604 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
8606 Make_Attribute_Definition_Clause (Loc,
8607 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8608 Chars => Name_Storage_Size,
8609 Expression => Make_Integer_Literal (Loc, 0)));
8611 Obj_Expr := Make_Identifier (Loc, Name_V);
8613 -- Unconstrained arrays require special processing in order to retrieve
8614 -- the elements. To achieve this, we have to skip the dope vector which
8615 -- lays in front of the elements and then use a thin pointer to perform
8616 -- the address-to-access conversion.
8618 if Is_Array_Type (Typ)
8619 and then not Is_Constrained (First_Subtype (Typ))
8622 Dope_Id : Entity_Id;
8625 -- Ensure that Ptr_Typ a thin pointer, generate:
8626 -- for Ptr_Typ'Size use System.Address'Size;
8629 Make_Attribute_Definition_Clause (Loc,
8630 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8633 Make_Integer_Literal (Loc, System_Address_Size)));
8636 -- Dnn : constant Storage_Offset :=
8637 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8639 Dope_Id := Make_Temporary (Loc, 'D');
8642 Make_Object_Declaration (Loc,
8643 Defining_Identifier => Dope_Id,
8644 Constant_Present => True,
8645 Object_Definition =>
8646 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
8648 Make_Op_Divide (Loc,
8650 Make_Attribute_Reference (Loc,
8651 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
8652 Attribute_Name => Name_Descriptor_Size),
8654 Make_Integer_Literal (Loc, System_Storage_Unit))));
8656 -- Shift the address from the start of the dope vector to the
8657 -- start of the elements:
8661 -- Note that this is done through a wrapper routine since RTSfind
8662 -- cannot retrieve operations with string names of the form "+".
8665 Make_Function_Call (Loc,
8667 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
8668 Parameter_Associations => New_List (
8670 New_Occurrence_Of (Dope_Id, Loc)));
8677 Make_Explicit_Dereference (Loc,
8678 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
8681 if Present (Fin_Call) then
8683 Make_Block_Statement (Loc,
8684 Declarations => Decls,
8685 Handled_Statement_Sequence =>
8686 Make_Handled_Sequence_Of_Statements (Loc,
8687 Statements => New_List (Fin_Call)));
8689 -- Otherwise previous errors or a missing full view may prevent the
8690 -- proper freezing of the designated type. If this is the case, there
8691 -- is no [Deep_]Finalize primitive to call.
8694 Fin_Block := Make_Null_Statement (Loc);
8697 return New_List (Fin_Block);
8698 end Make_Finalize_Address_Stmts;
8700 -------------------------------------
8701 -- Make_Handler_For_Ctrl_Operation --
8702 -------------------------------------
8706 -- when E : others =>
8707 -- Raise_From_Controlled_Operation (E);
8712 -- raise Program_Error [finalize raised exception];
8714 -- depending on whether Raise_From_Controlled_Operation is available
8716 function Make_Handler_For_Ctrl_Operation
8717 (Loc : Source_Ptr) return Node_Id
8720 -- Choice parameter (for the first case above)
8722 Raise_Node : Node_Id;
8723 -- Procedure call or raise statement
8726 -- Standard run-time: add choice parameter E and pass it to
8727 -- Raise_From_Controlled_Operation so that the original exception
8728 -- name and message can be recorded in the exception message for
8731 if RTE_Available (RE_Raise_From_Controlled_Operation) then
8732 E_Occ := Make_Defining_Identifier (Loc, Name_E);
8734 Make_Procedure_Call_Statement (Loc,
8737 (RTE (RE_Raise_From_Controlled_Operation), Loc),
8738 Parameter_Associations => New_List (
8739 New_Occurrence_Of (E_Occ, Loc)));
8741 -- Restricted run-time: exception messages are not supported
8746 Make_Raise_Program_Error (Loc,
8747 Reason => PE_Finalize_Raised_Exception);
8751 Make_Implicit_Exception_Handler (Loc,
8752 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8753 Choice_Parameter => E_Occ,
8754 Statements => New_List (Raise_Node));
8755 end Make_Handler_For_Ctrl_Operation;
8757 --------------------
8758 -- Make_Init_Call --
8759 --------------------
8761 function Make_Init_Call
8763 Typ : Entity_Id) return Node_Id
8765 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8774 -- Deal with the type and object reference. Depending on the context, an
8775 -- object reference may need several conversions.
8777 if Is_Concurrent_Type (Typ) then
8779 Utyp := Corresponding_Record_Type (Typ);
8780 Ref := Convert_Concurrent (Ref, Typ);
8782 elsif Is_Private_Type (Typ)
8783 and then Present (Full_View (Typ))
8784 and then Is_Concurrent_Type (Underlying_Type (Typ))
8787 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8788 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8795 Utyp := Underlying_Type (Base_Type (Utyp));
8796 Set_Assignment_OK (Ref);
8798 -- Deal with untagged derivation of private views
8800 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
8801 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8802 Ref := Unchecked_Convert_To (Utyp, Ref);
8804 -- The following is to prevent problems with UC see 1.156 RH ???
8806 Set_Assignment_OK (Ref);
8809 -- If the underlying_type is a subtype, then we are dealing with the
8810 -- completion of a private type. We need to access the base type and
8811 -- generate a conversion to it.
8813 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8814 pragma Assert (Is_Private_Type (Typ));
8815 Utyp := Base_Type (Utyp);
8816 Ref := Unchecked_Convert_To (Utyp, Ref);
8819 -- The underlying type may not be present due to a missing full view.
8820 -- In this case freezing did not take place and there is no suitable
8821 -- [Deep_]Initialize primitive to call.
8827 -- Select the appropriate version of initialize
8829 if Has_Controlled_Component (Utyp) then
8830 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
8832 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
8833 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
8836 -- If initialization procedure for an array of controlled objects is
8837 -- trivial, do not generate a useless call to it.
8839 if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
8841 (not Comes_From_Source (Proc)
8842 and then Present (Alias (Proc))
8843 and then Is_Trivial_Subprogram (Alias (Proc)))
8845 return Make_Null_Statement (Loc);
8848 -- The object reference may need another conversion depending on the
8849 -- type of the formal and that of the actual.
8851 Ref := Convert_View (Proc, Ref);
8854 -- [Deep_]Initialize (Ref);
8857 Make_Procedure_Call_Statement (Loc,
8858 Name => New_Occurrence_Of (Proc, Loc),
8859 Parameter_Associations => New_List (Ref));
8862 ------------------------------
8863 -- Make_Local_Deep_Finalize --
8864 ------------------------------
8866 function Make_Local_Deep_Finalize
8868 Nam : Entity_Id) return Node_Id
8870 Loc : constant Source_Ptr := Sloc (Typ);
8874 Formals := New_List (
8878 Make_Parameter_Specification (Loc,
8879 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
8881 Out_Present => True,
8882 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8884 -- F : Boolean := True
8886 Make_Parameter_Specification (Loc,
8887 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
8888 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
8889 Expression => New_Occurrence_Of (Standard_True, Loc)));
8891 -- Add the necessary number of counters to represent the initialization
8892 -- state of an object.
8895 Make_Subprogram_Body (Loc,
8897 Make_Procedure_Specification (Loc,
8898 Defining_Unit_Name => Nam,
8899 Parameter_Specifications => Formals),
8901 Declarations => No_List,
8903 Handled_Statement_Sequence =>
8904 Make_Handled_Sequence_Of_Statements (Loc,
8905 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
8906 end Make_Local_Deep_Finalize;
8908 ------------------------------------
8909 -- Make_Set_Finalize_Address_Call --
8910 ------------------------------------
8912 function Make_Set_Finalize_Address_Call
8914 Ptr_Typ : Entity_Id) return Node_Id
8916 -- It is possible for Ptr_Typ to be a partial view, if the access type
8917 -- is a full view declared in the private part of a nested package, and
8918 -- the finalization actions take place when completing analysis of the
8919 -- enclosing unit. For this reason use Underlying_Type twice below.
8921 Desig_Typ : constant Entity_Id :=
8923 (Designated_Type (Underlying_Type (Ptr_Typ)));
8924 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
8925 Fin_Mas : constant Entity_Id :=
8926 Finalization_Master (Underlying_Type (Ptr_Typ));
8929 -- Both the finalization master and primitive Finalize_Address must be
8932 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
8935 -- Set_Finalize_Address
8936 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8939 Make_Procedure_Call_Statement (Loc,
8941 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
8942 Parameter_Associations => New_List (
8943 New_Occurrence_Of (Fin_Mas, Loc),
8945 Make_Attribute_Reference (Loc,
8946 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
8947 Attribute_Name => Name_Unrestricted_Access)));
8948 end Make_Set_Finalize_Address_Call;
8950 --------------------------
8951 -- Make_Transient_Block --
8952 --------------------------
8954 function Make_Transient_Block
8957 Par : Node_Id) return Node_Id
8959 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
8960 -- Determine whether scoping entity Id manages the secondary stack
8962 function Within_Loop_Statement (N : Node_Id) return Boolean;
8963 -- Return True when N appears within a loop and no block is containing N
8965 -----------------------
8966 -- Manages_Sec_Stack --
8967 -----------------------
8969 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
8973 -- An exception handler with a choice parameter utilizes a dummy
8974 -- block to provide a declarative region. Such a block should not
8975 -- be considered because it never manifests in the tree and can
8976 -- never release the secondary stack.
8980 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
8987 return Uses_Sec_Stack (Id);
8992 end Manages_Sec_Stack;
8994 ---------------------------
8995 -- Within_Loop_Statement --
8996 ---------------------------
8998 function Within_Loop_Statement (N : Node_Id) return Boolean is
8999 Par : Node_Id := Parent (N);
9002 while not (Nkind_In (Par, N_Handled_Sequence_Of_Statements,
9004 N_Package_Specification)
9005 or else Nkind (Par) in N_Proper_Body)
9007 pragma Assert (Present (Par));
9008 Par := Parent (Par);
9011 return Nkind (Par) = N_Loop_Statement;
9012 end Within_Loop_Statement;
9016 Decls : constant List_Id := New_List;
9017 Instrs : constant List_Id := New_List (Action);
9018 Trans_Id : constant Entity_Id := Current_Scope;
9024 -- Start of processing for Make_Transient_Block
9027 -- Even though the transient block is tasked with managing the secondary
9028 -- stack, the block may forgo this functionality depending on how the
9029 -- secondary stack is managed by enclosing scopes.
9031 if Manages_Sec_Stack (Trans_Id) then
9033 -- Determine whether an enclosing scope already manages the secondary
9036 Scop := Scope (Trans_Id);
9037 while Present (Scop) loop
9039 -- It should not be possible to reach Standard without hitting one
9040 -- of the other cases first unless Standard was manually pushed.
9042 if Scop = Standard_Standard then
9045 -- The transient block is within a function which returns on the
9046 -- secondary stack. Take a conservative approach and assume that
9047 -- the value on the secondary stack is part of the result. Note
9048 -- that it is not possible to detect this dependency without flow
9049 -- analysis which the compiler does not have. Letting the object
9050 -- live longer than the transient block will not leak any memory
9051 -- because the caller will reclaim the total storage used by the
9054 elsif Ekind (Scop) = E_Function
9055 and then Sec_Stack_Needed_For_Return (Scop)
9057 Set_Uses_Sec_Stack (Trans_Id, False);
9060 -- The transient block must manage the secondary stack when the
9061 -- block appears within a loop in order to reclaim the memory at
9064 elsif Ekind (Scop) = E_Loop then
9067 -- Ditto when the block appears without a block that does not
9068 -- manage the secondary stack and is located within a loop.
9070 elsif Ekind (Scop) = E_Block
9071 and then not Manages_Sec_Stack (Scop)
9072 and then Present (Block_Node (Scop))
9073 and then Within_Loop_Statement (Block_Node (Scop))
9077 -- The transient block does not need to manage the secondary stack
9078 -- when there is an enclosing construct which already does that.
9079 -- This optimization saves on SS_Mark and SS_Release calls but may
9080 -- allow objects to live a little longer than required.
9082 -- The transient block must manage the secondary stack when switch
9083 -- -gnatd.s (strict management) is in effect.
9085 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
9086 Set_Uses_Sec_Stack (Trans_Id, False);
9089 -- Prevent the search from going too far because transient blocks
9090 -- are bounded by packages and subprogram scopes.
9092 elsif Ekind_In (Scop, E_Entry,
9102 Scop := Scope (Scop);
9106 -- Create the transient block. Set the parent now since the block itself
9107 -- is not part of the tree. The current scope is the E_Block entity that
9108 -- has been pushed by Establish_Transient_Scope.
9110 pragma Assert (Ekind (Trans_Id) = E_Block);
9113 Make_Block_Statement (Loc,
9114 Identifier => New_Occurrence_Of (Trans_Id, Loc),
9115 Declarations => Decls,
9116 Handled_Statement_Sequence =>
9117 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
9118 Has_Created_Identifier => True);
9119 Set_Parent (Block, Par);
9121 -- Insert actions stuck in the transient scopes as well as all freezing
9122 -- nodes needed by those actions. Do not insert cleanup actions here,
9123 -- they will be transferred to the newly created block.
9125 Insert_Actions_In_Scope_Around
9126 (Action, Clean => False, Manage_SS => False);
9128 Insert := Prev (Action);
9130 if Present (Insert) then
9131 Freeze_All (First_Entity (Trans_Id), Insert);
9134 -- Transfer cleanup actions to the newly created block
9137 Cleanup_Actions : List_Id
9138 renames Scope_Stack.Table (Scope_Stack.Last).
9139 Actions_To_Be_Wrapped (Cleanup);
9141 Set_Cleanup_Actions (Block, Cleanup_Actions);
9142 Cleanup_Actions := No_List;
9145 -- When the transient scope was established, we pushed the entry for the
9146 -- transient scope onto the scope stack, so that the scope was active
9147 -- for the installation of finalizable entities etc. Now we must remove
9148 -- this entry, since we have constructed a proper block.
9153 end Make_Transient_Block;
9155 ------------------------
9156 -- Node_To_Be_Wrapped --
9157 ------------------------
9159 function Node_To_Be_Wrapped return Node_Id is
9161 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
9162 end Node_To_Be_Wrapped;
9164 ----------------------------
9165 -- Set_Node_To_Be_Wrapped --
9166 ----------------------------
9168 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
9170 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
9171 end Set_Node_To_Be_Wrapped;
9173 ----------------------------
9174 -- Store_Actions_In_Scope --
9175 ----------------------------
9177 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
9178 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
9179 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
9182 if No (Actions) then
9185 if Is_List_Member (SE.Node_To_Be_Wrapped) then
9186 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
9188 Set_Parent (L, SE.Node_To_Be_Wrapped);
9193 elsif AK = Before then
9194 Insert_List_After_And_Analyze (Last (Actions), L);
9197 Insert_List_Before_And_Analyze (First (Actions), L);
9199 end Store_Actions_In_Scope;
9201 ----------------------------------
9202 -- Store_After_Actions_In_Scope --
9203 ----------------------------------
9205 procedure Store_After_Actions_In_Scope (L : List_Id) is
9207 Store_Actions_In_Scope (After, L);
9208 end Store_After_Actions_In_Scope;
9210 -----------------------------------
9211 -- Store_Before_Actions_In_Scope --
9212 -----------------------------------
9214 procedure Store_Before_Actions_In_Scope (L : List_Id) is
9216 Store_Actions_In_Scope (Before, L);
9217 end Store_Before_Actions_In_Scope;
9219 -----------------------------------
9220 -- Store_Cleanup_Actions_In_Scope --
9221 -----------------------------------
9223 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
9225 Store_Actions_In_Scope (Cleanup, L);
9226 end Store_Cleanup_Actions_In_Scope;
9232 procedure Unnest_Block (Decl : Node_Id) is
9233 Loc : constant Source_Ptr := Sloc (Decl);
9235 Local_Body : Node_Id;
9236 Local_Call : Node_Id;
9237 Local_Proc : Entity_Id;
9238 Local_Scop : Entity_Id;
9241 Local_Scop := Entity (Identifier (Decl));
9242 Ent := First_Entity (Local_Scop);
9245 Make_Defining_Identifier (Loc,
9246 Chars => New_Internal_Name ('P'));
9249 Make_Subprogram_Body (Loc,
9251 Make_Procedure_Specification (Loc,
9252 Defining_Unit_Name => Local_Proc),
9253 Declarations => Declarations (Decl),
9254 Handled_Statement_Sequence =>
9255 Handled_Statement_Sequence (Decl));
9257 Rewrite (Decl, Local_Body);
9259 Set_Has_Nested_Subprogram (Local_Proc);
9262 Make_Procedure_Call_Statement (Loc,
9263 Name => New_Occurrence_Of (Local_Proc, Loc));
9265 Insert_After (Decl, Local_Call);
9266 Analyze (Local_Call);
9268 -- The new subprogram has the same scope as the original block
9270 Set_Scope (Local_Proc, Scope (Local_Scop));
9272 -- And the entity list of the new procedure is that of the block
9274 Set_First_Entity (Local_Proc, Ent);
9276 -- Reset the scopes of all the entities to the new procedure
9278 while Present (Ent) loop
9279 Set_Scope (Ent, Local_Proc);
9288 procedure Unnest_Loop (Loop_Stmt : Node_Id) is
9289 Loc : constant Source_Ptr := Sloc (Loop_Stmt);
9291 Local_Body : Node_Id;
9292 Local_Call : Node_Id;
9293 Local_Proc : Entity_Id;
9294 Local_Scop : Entity_Id;
9295 Loop_Copy : constant Node_Id :=
9296 Relocate_Node (Loop_Stmt);
9298 Local_Scop := Entity (Identifier (Loop_Stmt));
9299 Ent := First_Entity (Local_Scop);
9302 Make_Defining_Identifier (Loc,
9303 Chars => New_Internal_Name ('P'));
9306 Make_Subprogram_Body (Loc,
9308 Make_Procedure_Specification (Loc,
9309 Defining_Unit_Name => Local_Proc),
9310 Declarations => Empty_List,
9311 Handled_Statement_Sequence =>
9312 Make_Handled_Sequence_Of_Statements (Loc,
9313 Statements => New_List (Loop_Copy)));
9315 Set_First_Real_Statement
9316 (Handled_Statement_Sequence (Local_Body), Loop_Copy);
9318 Rewrite (Loop_Stmt, Local_Body);
9319 Analyze (Loop_Stmt);
9321 Set_Has_Nested_Subprogram (Local_Proc);
9324 Make_Procedure_Call_Statement (Loc,
9325 Name => New_Occurrence_Of (Local_Proc, Loc));
9327 Insert_After (Loop_Stmt, Local_Call);
9328 Analyze (Local_Call);
9330 -- New procedure has the same scope as the original loop, and the scope
9331 -- of the loop is the new procedure.
9333 Set_Scope (Local_Proc, Scope (Local_Scop));
9334 Set_Scope (Local_Scop, Local_Proc);
9336 -- The entity list of the new procedure is that of the loop
9338 Set_First_Entity (Local_Proc, Ent);
9340 -- Note that the entities associated with the loop don't need to have
9341 -- their Scope fields reset, since they're still associated with the
9342 -- same loop entity that now belongs to the copied loop statement.
9345 --------------------------------
9346 -- Wrap_Transient_Declaration --
9347 --------------------------------
9349 -- If a transient scope has been established during the processing of the
9350 -- Expression of an Object_Declaration, it is not possible to wrap the
9351 -- declaration into a transient block as usual case, otherwise the object
9352 -- would be itself declared in the wrong scope. Therefore, all entities (if
9353 -- any) defined in the transient block are moved to the proper enclosing
9354 -- scope. Furthermore, if they are controlled variables they are finalized
9355 -- right after the declaration. The finalization list of the transient
9356 -- scope is defined as a renaming of the enclosing one so during their
9357 -- initialization they will be attached to the proper finalization list.
9358 -- For instance, the following declaration :
9360 -- X : Typ := F (G (A), G (B));
9362 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9363 -- is expanded into :
9365 -- X : Typ := [ complex Expression-Action ];
9366 -- [Deep_]Finalize (_v1);
9367 -- [Deep_]Finalize (_v2);
9369 procedure Wrap_Transient_Declaration (N : Node_Id) is
9374 Curr_S := Current_Scope;
9375 Encl_S := Scope (Curr_S);
9377 -- Insert all actions including cleanup generated while analyzing or
9378 -- expanding the transient context back into the tree. Manage the
9379 -- secondary stack when the object declaration appears in a library
9380 -- level package [body].
9382 Insert_Actions_In_Scope_Around
9386 Uses_Sec_Stack (Curr_S)
9387 and then Nkind (N) = N_Object_Declaration
9388 and then Ekind_In (Encl_S, E_Package, E_Package_Body)
9389 and then Is_Library_Level_Entity (Encl_S));
9392 -- Relocate local entities declared within the transient scope to the
9393 -- enclosing scope. This action sets their Is_Public flag accordingly.
9395 Transfer_Entities (Curr_S, Encl_S);
9397 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9398 -- is properly released upon exiting the said scope.
9400 if Uses_Sec_Stack (Curr_S) then
9401 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
9403 -- Do not mark a function that returns on the secondary stack as the
9404 -- reclamation is done by the caller.
9406 if Ekind (Curr_S) = E_Function
9407 and then Requires_Transient_Scope (Etype (Curr_S))
9411 -- Otherwise mark the enclosing dynamic scope
9414 Set_Uses_Sec_Stack (Curr_S);
9415 Check_Restriction (No_Secondary_Stack, N);
9418 end Wrap_Transient_Declaration;
9420 -------------------------------
9421 -- Wrap_Transient_Expression --
9422 -------------------------------
9424 procedure Wrap_Transient_Expression (N : Node_Id) is
9425 Loc : constant Source_Ptr := Sloc (N);
9426 Expr : Node_Id := Relocate_Node (N);
9427 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
9428 Typ : constant Entity_Id := Etype (N);
9435 -- M : constant Mark_Id := SS_Mark;
9436 -- procedure Finalizer is ... (See Build_Finalizer)
9439 -- Temp := <Expr>; -- general case
9440 -- Temp := (if <Expr> then True else False); -- boolean case
9446 -- A special case is made for Boolean expressions so that the back end
9447 -- knows to generate a conditional branch instruction, if running with
9448 -- -fpreserve-control-flow. This ensures that a control-flow change
9449 -- signaling the decision outcome occurs before the cleanup actions.
9451 if Opt.Suppress_Control_Flow_Optimizations
9452 and then Is_Boolean_Type (Typ)
9455 Make_If_Expression (Loc,
9456 Expressions => New_List (
9458 New_Occurrence_Of (Standard_True, Loc),
9459 New_Occurrence_Of (Standard_False, Loc)));
9462 Insert_Actions (N, New_List (
9463 Make_Object_Declaration (Loc,
9464 Defining_Identifier => Temp,
9465 Object_Definition => New_Occurrence_Of (Typ, Loc)),
9467 Make_Transient_Block (Loc,
9469 Make_Assignment_Statement (Loc,
9470 Name => New_Occurrence_Of (Temp, Loc),
9471 Expression => Expr),
9472 Par => Parent (N))));
9474 Rewrite (N, New_Occurrence_Of (Temp, Loc));
9475 Analyze_And_Resolve (N, Typ);
9476 end Wrap_Transient_Expression;
9478 ------------------------------
9479 -- Wrap_Transient_Statement --
9480 ------------------------------
9482 procedure Wrap_Transient_Statement (N : Node_Id) is
9483 Loc : constant Source_Ptr := Sloc (N);
9484 New_Stmt : constant Node_Id := Relocate_Node (N);
9489 -- M : constant Mark_Id := SS_Mark;
9490 -- procedure Finalizer is ... (See Build_Finalizer)
9500 Make_Transient_Block (Loc,
9502 Par => Parent (N)));
9504 -- With the scope stack back to normal, we can call analyze on the
9505 -- resulting block. At this point, the transient scope is being
9506 -- treated like a perfectly normal scope, so there is nothing
9507 -- special about it.
9509 -- Note: Wrap_Transient_Statement is called with the node already
9510 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9511 -- otherwise we would get a recursive processing of the node when
9512 -- we do this Analyze call.
9515 end Wrap_Transient_Statement;