1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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 Contracts; use Contracts;
32 with Debug; use Debug;
33 with Einfo; use Einfo;
34 with Einfo.Entities; use Einfo.Entities;
35 with Einfo.Utils; use Einfo.Utils;
36 with Elists; use Elists;
37 with Errout; use Errout;
38 with Exp_Ch6; use Exp_Ch6;
39 with Exp_Ch9; use Exp_Ch9;
40 with Exp_Ch11; use Exp_Ch11;
41 with Exp_Dbug; use Exp_Dbug;
42 with Exp_Dist; use Exp_Dist;
43 with Exp_Disp; use Exp_Disp;
44 with Exp_Prag; use Exp_Prag;
45 with Exp_Tss; use Exp_Tss;
46 with Exp_Util; use Exp_Util;
47 with Freeze; use Freeze;
48 with GNAT_CUDA; use GNAT_CUDA;
50 with Nlists; use Nlists;
51 with Nmake; use Nmake;
53 with Output; use Output;
54 with Restrict; use Restrict;
55 with Rident; use Rident;
56 with Rtsfind; use Rtsfind;
57 with Sinfo; use Sinfo;
58 with Sinfo.Nodes; use Sinfo.Nodes;
59 with Sinfo.Utils; use Sinfo.Utils;
61 with Sem_Aux; use Sem_Aux;
62 with Sem_Ch3; use Sem_Ch3;
63 with Sem_Ch7; use Sem_Ch7;
64 with Sem_Ch8; use Sem_Ch8;
65 with Sem_Res; use Sem_Res;
66 with Sem_Util; use Sem_Util;
67 with Snames; use Snames;
68 with Stand; use Stand;
69 with Tbuild; use Tbuild;
70 with Ttypes; use Ttypes;
71 with Uintp; use Uintp;
73 package body Exp_Ch7 is
75 --------------------------------
76 -- Transient Scope Management --
77 --------------------------------
79 -- A transient scope is created when temporary objects are created by the
80 -- compiler. These temporary objects are allocated on the secondary stack
81 -- and the transient scope is responsible for finalizing the object when
82 -- appropriate and reclaiming the memory at the right time. The temporary
83 -- objects are generally the objects allocated to store the result of a
84 -- function returning an unconstrained or a tagged value. Expressions
85 -- needing to be wrapped in a transient scope (functions calls returning
86 -- unconstrained or tagged values) may appear in 3 different contexts which
87 -- lead to 3 different kinds of transient scope expansion:
89 -- 1. In a simple statement (procedure call, assignment, ...). In this
90 -- case the instruction is wrapped into a transient block. See
91 -- Wrap_Transient_Statement for details.
93 -- 2. In an expression of a control structure (test in a IF statement,
94 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
97 -- 3. In a expression of an object_declaration. No wrapping is possible
98 -- here, so the finalization actions, if any, are done right after the
99 -- declaration and the secondary stack deallocation is done in the
100 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
102 -- Note about functions returning tagged types: it has been decided to
103 -- always allocate their result in the secondary stack, even though is not
104 -- absolutely mandatory when the tagged type is constrained because the
105 -- caller knows the size of the returned object and thus could allocate the
106 -- result in the primary stack. An exception to this is when the function
107 -- builds its result in place, as is done for functions with inherently
108 -- limited result types for Ada 2005. In that case, certain callers may
109 -- pass the address of a constrained object as the target object for the
112 -- By allocating tagged results in the secondary stack a number of
113 -- implementation difficulties are avoided:
115 -- - If it is a dispatching function call, the computation of the size of
116 -- the result is possible but complex from the outside.
118 -- - If the returned type is controlled, the assignment of the returned
119 -- value to the anonymous object involves an Adjust, and we have no
120 -- easy way to access the anonymous object created by the back end.
122 -- - If the returned type is class-wide, this is an unconstrained type
125 -- Furthermore, the small loss in efficiency which is the result of this
126 -- decision is not such a big deal because functions returning tagged types
127 -- are not as common in practice compared to functions returning access to
130 --------------------------------------------------
131 -- Transient Blocks and Finalization Management --
132 --------------------------------------------------
134 function Find_Transient_Context (N : Node_Id) return Node_Id;
135 -- Locate a suitable context for arbitrary node N which may need to be
136 -- serviced by a transient scope. Return Empty if no suitable context is
139 procedure Insert_Actions_In_Scope_Around
142 Manage_SS : Boolean);
143 -- Insert the before-actions kept in the scope stack before N, and the
144 -- after-actions after N, which must be a member of a list. If flag Clean
145 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
146 -- calls to mark and release the secondary stack.
148 function Make_Transient_Block
151 Par : Node_Id) return Node_Id;
152 -- Action is a single statement or object declaration. Par is the proper
153 -- parent of the generated block. Create a transient block whose name is
154 -- the current scope and the only handled statement is Action. If Action
155 -- involves controlled objects or secondary stack usage, the corresponding
156 -- cleanup actions are performed at the end of the block.
158 procedure Set_Node_To_Be_Wrapped (N : Node_Id);
159 -- Set the field Node_To_Be_Wrapped of the current scope
161 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
162 -- Shared processing for Store_xxx_Actions_In_Scope
164 -----------------------------
165 -- Finalization Management --
166 -----------------------------
168 -- This part describe how Initialization/Adjustment/Finalization procedures
169 -- are generated and called. Two cases must be considered, types that are
170 -- Controlled (Is_Controlled flag set) and composite types that contain
171 -- controlled components (Has_Controlled_Component flag set). In the first
172 -- case the procedures to call are the user-defined primitive operations
173 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
174 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
175 -- of calling the former procedures on the controlled components.
177 -- For records with Has_Controlled_Component set, a hidden "controller"
178 -- component is inserted. This controller component contains its own
179 -- finalization list on which all controlled components are attached
180 -- creating an indirection on the upper-level Finalization list. This
181 -- technique facilitates the management of objects whose number of
182 -- controlled components changes during execution. This controller
183 -- component is itself controlled and is attached to the upper-level
184 -- finalization chain. Its adjust primitive is in charge of calling adjust
185 -- on the components and adjusting the finalization pointer to match their
186 -- new location (see a-finali.adb).
188 -- It is not possible to use a similar technique for arrays that have
189 -- Has_Controlled_Component set. In this case, deep procedures are
190 -- generated that call initialize/adjust/finalize + attachment or
191 -- detachment on the finalization list for all component.
193 -- Initialize calls: they are generated for declarations or dynamic
194 -- allocations of Controlled objects with no initial value. They are always
195 -- followed by an attachment to the current Finalization Chain. For the
196 -- dynamic allocation case this the chain attached to the scope of the
197 -- access type definition otherwise, this is the chain of the current
200 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
201 -- or dynamic allocations of Controlled objects with an initial value.
202 -- (2) after an assignment. In the first case they are followed by an
203 -- attachment to the final chain, in the second case they are not.
205 -- Finalization Calls: They are generated on (1) scope exit, (2)
206 -- assignments, (3) unchecked deallocations. In case (3) they have to
207 -- be detached from the final chain, in case (2) they must not and in
208 -- case (1) this is not important since we are exiting the scope anyway.
212 -- Type extensions will have a new record controller at each derivation
213 -- level containing controlled components. The record controller for
214 -- the parent/ancestor is attached to the finalization list of the
215 -- extension's record controller (i.e. the parent is like a component
216 -- of the extension).
218 -- For types that are both Is_Controlled and Has_Controlled_Components,
219 -- the record controller and the object itself are handled separately.
220 -- It could seem simpler to attach the object at the end of its record
221 -- controller but this would not tackle view conversions properly.
223 -- A classwide type can always potentially have controlled components
224 -- but the record controller of the corresponding actual type may not
225 -- be known at compile time so the dispatch table contains a special
226 -- field that allows computation of the offset of the record controller
227 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
229 -- Here is a simple example of the expansion of a controlled block :
233 -- Y : Controlled := Init;
239 -- Z : R := (C => X);
249 -- _L : System.FI.Finalizable_Ptr;
251 -- procedure _Clean is
254 -- System.FI.Finalize_List (_L);
262 -- Attach_To_Final_List (_L, Finalizable (X), 1);
263 -- at end: Abort_Undefer;
264 -- Y : Controlled := Init;
266 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
274 -- Deep_Initialize (W, _L, 1);
275 -- at end: Abort_Under;
276 -- Z : R := (C => X);
277 -- Deep_Adjust (Z, _L, 1);
281 -- Deep_Finalize (W, False);
282 -- <save W's final pointers>
284 -- <restore W's final pointers>
285 -- Deep_Adjust (W, _L, 0);
290 type Final_Primitives is
291 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
292 -- This enumeration type is defined in order to ease sharing code for
293 -- building finalization procedures for composite types.
295 Name_Of : constant array (Final_Primitives) of Name_Id :=
296 (Initialize_Case => Name_Initialize,
297 Adjust_Case => Name_Adjust,
298 Finalize_Case => Name_Finalize,
299 Address_Case => Name_Finalize_Address);
300 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
301 (Initialize_Case => TSS_Deep_Initialize,
302 Adjust_Case => TSS_Deep_Adjust,
303 Finalize_Case => TSS_Deep_Finalize,
304 Address_Case => TSS_Finalize_Address);
306 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
307 -- Determine whether access type Typ may have a finalization master
309 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
310 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
311 -- Has_Controlled_Component set and store them using the TSS mechanism.
313 function Build_Cleanup_Statements
315 Additional_Cleanup : List_Id) return List_Id;
316 -- Create the cleanup calls for an asynchronous call block, task master,
317 -- protected subprogram body, task allocation block or task body, or
318 -- additional cleanup actions parked on a transient block. If the context
319 -- does not contain the above constructs, the routine returns an empty
322 procedure Build_Finalizer
324 Clean_Stmts : List_Id;
327 Defer_Abort : Boolean;
328 Fin_Id : out Entity_Id);
329 -- N may denote an accept statement, block, entry body, package body,
330 -- package spec, protected body, subprogram body, or a task body. Create
331 -- a procedure which contains finalization calls for all controlled objects
332 -- declared in the declarative or statement region of N. The calls are
333 -- built in reverse order relative to the original declarations. In the
334 -- case of a task body, the routine delays the creation of the finalizer
335 -- until all statements have been moved to the task body procedure.
336 -- Clean_Stmts may contain additional context-dependent code used to abort
337 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
338 -- Mark_Id is the secondary stack used in the current context or Empty if
339 -- missing. Top_Decls is the list on which the declaration of the finalizer
340 -- is attached in the non-package case. Defer_Abort indicates that the
341 -- statements passed in perform actions that require abort to be deferred,
342 -- such as for task termination. Fin_Id is the finalizer declaration
345 procedure Build_Finalizer_Helper
347 Clean_Stmts : List_Id;
350 Defer_Abort : Boolean;
351 Fin_Id : out Entity_Id;
352 Finalize_Old_Only : Boolean);
353 -- An internal routine which does all of the heavy lifting on behalf of
356 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
357 -- N is a construct which contains a handled sequence of statements, Fin_Id
358 -- is the entity of a finalizer. Create an At_End handler which covers the
359 -- statements of N and calls Fin_Id. If the handled statement sequence has
360 -- an exception handler, the statements will be wrapped in a block to avoid
361 -- unwanted interaction with the new At_End handler.
363 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
364 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
365 -- Has_Component_Component set and store them using the TSS mechanism.
367 -------------------------------------------
368 -- Unnesting procedures for CCG and LLVM --
369 -------------------------------------------
371 -- Expansion generates subprograms for controlled types management that
372 -- may appear in declarative lists in package declarations and bodies.
373 -- These subprograms appear within generated blocks that contain local
374 -- declarations and a call to finalization procedures. To ensure that
375 -- such subprograms get activation records when needed, we transform the
376 -- block into a procedure body, followed by a call to it in the same
379 procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
380 -- The statement part of a package body that is a compilation unit may
381 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
382 -- Mode such subprograms must be handled as nested inside the (implicit)
383 -- elaboration procedure that executes that statement part. To handle
384 -- properly uplevel references we construct that subprogram explicitly,
385 -- to contain blocks and inner subprograms, the statement part becomes
386 -- a call to this subprogram. This is only done if blocks are present
387 -- in the statement list of the body. (It would be nice to unify this
388 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
389 -- they're doing very similar work, but are structured differently. ???)
391 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
392 -- Similarly, the declarations or statements in library-level packages may
393 -- have created blocks with nested subprograms. Such a block must be
394 -- transformed into a procedure followed by a call to it, so that unnesting
395 -- can handle uplevel references within these nested subprograms (typically
396 -- subprograms that handle finalization actions). This also applies to
397 -- nested packages, including instantiations, in which case it must
398 -- recursively process inner bodies.
400 procedure Check_Unnesting_In_Handlers (N : Node_Id);
401 -- Similarly, check for blocks with nested subprograms occurring within
402 -- a set of exception handlers associated with a package body N.
404 procedure Unnest_Block (Decl : Node_Id);
405 -- Blocks that contain nested subprograms with up-level references need to
406 -- create activation records for them. We do this by rewriting the block as
407 -- a procedure, followed by a call to it in the same declarative list, to
408 -- replicate the semantics of the original block.
410 -- A common source for such block is a transient block created for a
411 -- construct (declaration, assignment, etc.) that involves controlled
412 -- actions or secondary-stack management, in which case the nested
413 -- subprogram is a finalizer.
415 procedure Unnest_If_Statement (If_Stmt : Node_Id);
416 -- The separate statement lists associated with an if-statement (then part,
417 -- elsif parts, else part) may require unnesting if they directly contain
418 -- a subprogram body that references up-level objects. Each statement list
419 -- is traversed to locate such subprogram bodies, and if a part's statement
420 -- list contains a body, then the list is replaced with a new procedure
421 -- containing the part's statements followed by a call to the procedure.
422 -- Furthermore, any nested blocks, loops, or if statements will also be
423 -- traversed to determine the need for further unnesting transformations.
425 procedure Unnest_Statement_List (Stmts : in out List_Id);
426 -- A list of statements that directly contains a subprogram at its outer
427 -- level, that may reference objects declared in that same statement list,
428 -- is rewritten as a procedure containing the statement list Stmts (which
429 -- includes any such objects as well as the nested subprogram), followed by
430 -- a call to the new procedure, and Stmts becomes the list containing the
431 -- procedure and the call. This ensures that Unnest_Subprogram will later
432 -- properly handle up-level references from the nested subprogram to
433 -- objects declared earlier in statement list, by creating an activation
434 -- record and passing it to the nested subprogram. This procedure also
435 -- resets the Scope of objects declared in the statement list, as well as
436 -- the Scope of the nested subprogram, to refer to the new procedure.
437 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
438 -- only be called when known that the statement list contains a subprogram.
440 procedure Unnest_Loop (Loop_Stmt : Node_Id);
441 -- Top-level Loops that contain nested subprograms with up-level references
442 -- need to have activation records. We do this by rewriting the loop as a
443 -- procedure containing the loop, followed by a call to the procedure in
444 -- the same library-level declarative list, to replicate the semantics of
445 -- the original loop. Such loops can occur due to aggregate expansions and
448 procedure Check_Visibly_Controlled
449 (Prim : Final_Primitives;
451 E : in out Entity_Id;
452 Cref : in out Node_Id);
453 -- The controlled operation declared for a derived type may not be
454 -- overriding, if the controlled operations of the parent type are hidden,
455 -- for example when the parent is a private type whose full view is
456 -- controlled. For other primitive operations we modify the name of the
457 -- operation to indicate that it is not overriding, but this is not
458 -- possible for Initialize, etc. because they have to be retrievable by
459 -- name. Before generating the proper call to one of these operations we
460 -- check whether Typ is known to be controlled at the point of definition.
461 -- If it is not then we must retrieve the hidden operation of the parent
462 -- and use it instead. This is one case that might be solved more cleanly
463 -- once Overriding pragmas or declarations are in place.
465 function Contains_Subprogram (Blk : Entity_Id) return Boolean;
466 -- Check recursively whether a loop or block contains a subprogram that
467 -- may need an activation record.
469 function Convert_View
472 Ind : Pos := 1) return Node_Id;
473 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
474 -- argument being passed to it. Ind indicates which formal of procedure
475 -- Proc we are trying to match. This function will, if necessary, generate
476 -- a conversion between the partial and full view of Arg to match the type
477 -- of the formal of Proc, or force a conversion to the class-wide type in
478 -- the case where the operation is abstract.
480 function Enclosing_Function (E : Entity_Id) return Entity_Id;
481 -- Given an arbitrary entity, traverse the scope chain looking for the
482 -- first enclosing function. Return Empty if no function was found.
488 Skip_Self : Boolean := False) return Node_Id;
489 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
490 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
491 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
492 -- action has an effect on the components only (if any).
494 function Make_Deep_Proc
495 (Prim : Final_Primitives;
497 Stmts : List_Id) return Node_Id;
498 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
499 -- Deep_Finalize procedures according to the first parameter, these
500 -- procedures operate on the type Typ. The Stmts parameter gives the body
503 function Make_Deep_Array_Body
504 (Prim : Final_Primitives;
505 Typ : Entity_Id) return List_Id;
506 -- This function generates the list of statements for implementing
507 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
508 -- the first parameter, these procedures operate on the array type Typ.
510 function Make_Deep_Record_Body
511 (Prim : Final_Primitives;
513 Is_Local : Boolean := False) return List_Id;
514 -- This function generates the list of statements for implementing
515 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
516 -- the first parameter, these procedures operate on the record type Typ.
517 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
518 -- whether the inner logic should be dictated by state counters.
520 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
521 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
522 -- Make_Deep_Record_Body. Generate the following statements:
525 -- type Acc_Typ is access all Typ;
526 -- for Acc_Typ'Storage_Size use 0;
528 -- [Deep_]Finalize (Acc_Typ (V).all);
531 --------------------------------
532 -- Allows_Finalization_Master --
533 --------------------------------
535 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
536 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
537 -- Determine whether entity E is inside a wrapper package created for
538 -- an instance of Ada.Unchecked_Deallocation.
540 ------------------------------
541 -- In_Deallocation_Instance --
542 ------------------------------
544 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
545 Pkg : constant Entity_Id := Scope (E);
546 Par : Node_Id := Empty;
549 if Ekind (Pkg) = E_Package
550 and then Present (Related_Instance (Pkg))
551 and then Ekind (Related_Instance (Pkg)) = E_Procedure
553 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
557 and then Chars (Par) = Name_Unchecked_Deallocation
558 and then Chars (Scope (Par)) = Name_Ada
559 and then Scope (Scope (Par)) = Standard_Standard;
563 end In_Deallocation_Instance;
567 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
568 Ptr_Typ : constant Entity_Id :=
569 Root_Type_Of_Full_View (Base_Type (Typ));
571 -- Start of processing for Allows_Finalization_Master
574 -- Certain run-time configurations and targets do not provide support
575 -- for controlled types and therefore do not need masters.
577 if Restriction_Active (No_Finalization) then
580 -- Do not consider C and C++ types since it is assumed that the non-Ada
581 -- side will handle their cleanup.
583 elsif Convention (Desig_Typ) = Convention_C
584 or else Convention (Desig_Typ) = Convention_CPP
588 -- Do not consider an access type that returns on the secondary stack
590 elsif Present (Associated_Storage_Pool (Ptr_Typ))
591 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
595 -- Do not consider an access type that can never allocate an object
597 elsif No_Pool_Assigned (Ptr_Typ) then
600 -- Do not consider an access type coming from an Unchecked_Deallocation
601 -- instance. Even though the designated type may be controlled, the
602 -- access type will never participate in any allocations.
604 elsif In_Deallocation_Instance (Ptr_Typ) then
607 -- Do not consider a non-library access type when No_Nested_Finalization
608 -- is in effect since finalization masters are controlled objects and if
609 -- created will violate the restriction.
611 elsif Restriction_Active (No_Nested_Finalization)
612 and then not Is_Library_Level_Entity (Ptr_Typ)
616 -- Do not consider an access type subject to pragma No_Heap_Finalization
617 -- because objects allocated through such a type are not to be finalized
618 -- when the access type goes out of scope.
620 elsif No_Heap_Finalization (Ptr_Typ) then
623 -- Do not create finalization masters in GNATprove mode because this
624 -- causes unwanted extra expansion. A compilation in this mode must
625 -- keep the tree as close as possible to the original sources.
627 elsif GNATprove_Mode then
630 -- Otherwise the access type may use a finalization master
635 end Allows_Finalization_Master;
637 ----------------------------
638 -- Build_Anonymous_Master --
639 ----------------------------
641 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
642 function Create_Anonymous_Master
643 (Desig_Typ : Entity_Id;
645 Unit_Decl : Node_Id) return Entity_Id;
646 -- Create a new anonymous master for access type Ptr_Typ with designated
647 -- type Desig_Typ. The declaration of the master and its initialization
648 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
649 -- the entity of Unit_Decl.
651 function Current_Anonymous_Master
652 (Desig_Typ : Entity_Id;
653 Unit_Id : Entity_Id) return Entity_Id;
654 -- Find an anonymous master declared within unit Unit_Id which services
655 -- designated type Desig_Typ. If there is no such master, return Empty.
657 -----------------------------
658 -- Create_Anonymous_Master --
659 -----------------------------
661 function Create_Anonymous_Master
662 (Desig_Typ : Entity_Id;
664 Unit_Decl : Node_Id) return Entity_Id
666 Loc : constant Source_Ptr := Sloc (Unit_Id);
677 -- <FM_Id> : Finalization_Master;
679 FM_Id := Make_Temporary (Loc, 'A');
682 Make_Object_Declaration (Loc,
683 Defining_Identifier => FM_Id,
685 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
689 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
692 Make_Procedure_Call_Statement (Loc,
694 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
695 Parameter_Associations => New_List (
696 New_Occurrence_Of (FM_Id, Loc),
697 Make_Attribute_Reference (Loc,
699 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
700 Attribute_Name => Name_Unrestricted_Access)));
702 -- Find the declarative list of the unit
704 if Nkind (Unit_Decl) = N_Package_Declaration then
705 Unit_Spec := Specification (Unit_Decl);
706 Decls := Visible_Declarations (Unit_Spec);
710 Set_Visible_Declarations (Unit_Spec, Decls);
713 -- Package body or subprogram case
715 -- ??? A subprogram spec or body that acts as a compilation unit may
716 -- contain a formal parameter of an anonymous access-to-controlled
717 -- type initialized by an allocator.
719 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
721 -- There is no suitable place to create the master as the subprogram
722 -- is not in a declarative list.
725 Decls := Declarations (Unit_Decl);
729 Set_Declarations (Unit_Decl, Decls);
733 Prepend_To (Decls, FM_Init);
734 Prepend_To (Decls, FM_Decl);
736 -- Use the scope of the unit when analyzing the declaration of the
737 -- master and its initialization actions.
739 Push_Scope (Unit_Id);
744 -- Mark the master as servicing this specific designated type
746 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
748 -- Include the anonymous master in the list of existing masters which
749 -- appear in this unit. This effectively creates a mapping between a
750 -- master and a designated type which in turn allows for the reuse of
751 -- masters on a per-unit basis.
753 All_FMs := Anonymous_Masters (Unit_Id);
756 All_FMs := New_Elmt_List;
757 Set_Anonymous_Masters (Unit_Id, All_FMs);
760 Prepend_Elmt (FM_Id, All_FMs);
763 end Create_Anonymous_Master;
765 ------------------------------
766 -- Current_Anonymous_Master --
767 ------------------------------
769 function Current_Anonymous_Master
770 (Desig_Typ : Entity_Id;
771 Unit_Id : Entity_Id) return Entity_Id
773 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
778 -- Inspect the list of anonymous masters declared within the unit
779 -- looking for an existing master which services the same designated
782 if Present (All_FMs) then
783 FM_Elmt := First_Elmt (All_FMs);
784 while Present (FM_Elmt) loop
785 FM_Id := Node (FM_Elmt);
787 -- The currect master services the same designated type. As a
788 -- result the master can be reused and associated with another
789 -- anonymous access-to-controlled type.
791 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
800 end Current_Anonymous_Master;
804 Desig_Typ : Entity_Id;
806 Priv_View : Entity_Id;
810 -- Start of processing for Build_Anonymous_Master
813 -- Nothing to do if the circumstances do not allow for a finalization
816 if not Allows_Finalization_Master (Ptr_Typ) then
820 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
821 Unit_Id := Unique_Defining_Entity (Unit_Decl);
823 -- The compilation unit is a package instantiation. In this case the
824 -- anonymous master is associated with the package spec as both the
825 -- spec and body appear at the same level.
827 if Nkind (Unit_Decl) = N_Package_Body
828 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
830 Unit_Id := Corresponding_Spec (Unit_Decl);
831 Unit_Decl := Unit_Declaration_Node (Unit_Id);
834 -- Use the initial declaration of the designated type when it denotes
835 -- the full view of an incomplete or private type. This ensures that
836 -- types with one and two views are treated the same.
838 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
839 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
841 if Present (Priv_View) then
842 Desig_Typ := Priv_View;
845 -- Determine whether the current semantic unit already has an anonymous
846 -- master which services the designated type.
848 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
850 -- If this is not the case, create a new master
853 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
856 Set_Finalization_Master (Ptr_Typ, FM_Id);
857 end Build_Anonymous_Master;
859 ----------------------------
860 -- Build_Array_Deep_Procs --
861 ----------------------------
863 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
867 (Prim => Initialize_Case,
869 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
871 if not Is_Limited_View (Typ) then
874 (Prim => Adjust_Case,
876 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
879 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
880 -- suppressed since these routine will not be used.
882 if not Restriction_Active (No_Finalization) then
885 (Prim => Finalize_Case,
887 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
889 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
891 if not CodePeer_Mode then
894 (Prim => Address_Case,
896 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
899 end Build_Array_Deep_Procs;
901 ------------------------------
902 -- Build_Cleanup_Statements --
903 ------------------------------
905 function Build_Cleanup_Statements
907 Additional_Cleanup : List_Id) return List_Id
909 Is_Asynchronous_Call : constant Boolean :=
910 Nkind (N) = N_Block_Statement
911 and then Is_Asynchronous_Call_Block (N);
912 Is_Master : constant Boolean :=
913 Nkind (N) /= N_Entry_Body
914 and then Is_Task_Master (N);
915 Is_Protected_Body : constant Boolean :=
916 Nkind (N) = N_Subprogram_Body
917 and then Is_Protected_Subprogram_Body (N);
918 Is_Task_Allocation : constant Boolean :=
919 Nkind (N) = N_Block_Statement
920 and then Is_Task_Allocation_Block (N);
921 Is_Task_Body : constant Boolean :=
922 Nkind (Original_Node (N)) = N_Task_Body;
924 Loc : constant Source_Ptr := Sloc (N);
925 Stmts : constant List_Id := New_List;
929 if Restricted_Profile then
931 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
933 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
937 if Restriction_Active (No_Task_Hierarchy) = False then
938 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
941 -- Add statements to unlock the protected object parameter and to
942 -- undefer abort. If the context is a protected procedure and the object
943 -- has entries, call the entry service routine.
945 -- NOTE: The generated code references _object, a parameter to the
948 elsif Is_Protected_Body then
950 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
951 Conc_Typ : Entity_Id := Empty;
953 Param_Typ : Entity_Id;
956 -- Find the _object parameter representing the protected object
958 Param := First (Parameter_Specifications (Spec));
960 Param_Typ := Etype (Parameter_Type (Param));
962 if Ekind (Param_Typ) = E_Record_Type then
963 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
966 exit when No (Param) or else Present (Conc_Typ);
970 pragma Assert (Present (Param));
971 pragma Assert (Present (Conc_Typ));
973 -- Historical note: In earlier versions of GNAT, there was code
974 -- at this point to generate stuff to service entry queues. It is
975 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
977 Build_Protected_Subprogram_Call_Cleanup
978 (Specification (N), Conc_Typ, Loc, Stmts);
981 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
982 -- tasks. Other unactivated tasks are completed by Complete_Task or
985 -- NOTE: The generated code references _chain, a local object
987 elsif Is_Task_Allocation then
990 -- Expunge_Unactivated_Tasks (_chain);
992 -- where _chain is the list of tasks created by the allocator but not
993 -- yet activated. This list will be empty unless the block completes
997 Make_Procedure_Call_Statement (Loc,
1000 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
1001 Parameter_Associations => New_List (
1002 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
1004 -- Attempt to cancel an asynchronous entry call whenever the block which
1005 -- contains the abortable part is exited.
1007 -- NOTE: The generated code references Cnn, a local object
1009 elsif Is_Asynchronous_Call then
1011 Cancel_Param : constant Entity_Id :=
1012 Entry_Cancel_Parameter (Entity (Identifier (N)));
1015 -- If it is of type Communication_Block, this must be a protected
1016 -- entry call. Generate:
1018 -- if Enqueued (Cancel_Param) then
1019 -- Cancel_Protected_Entry_Call (Cancel_Param);
1022 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
1024 Make_If_Statement (Loc,
1026 Make_Function_Call (Loc,
1028 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
1029 Parameter_Associations => New_List (
1030 New_Occurrence_Of (Cancel_Param, Loc))),
1032 Then_Statements => New_List (
1033 Make_Procedure_Call_Statement (Loc,
1036 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
1037 Parameter_Associations => New_List (
1038 New_Occurrence_Of (Cancel_Param, Loc))))));
1040 -- Asynchronous delay, generate:
1041 -- Cancel_Async_Delay (Cancel_Param);
1043 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
1045 Make_Procedure_Call_Statement (Loc,
1047 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
1048 Parameter_Associations => New_List (
1049 Make_Attribute_Reference (Loc,
1051 New_Occurrence_Of (Cancel_Param, Loc),
1052 Attribute_Name => Name_Unchecked_Access))));
1054 -- Task entry call, generate:
1055 -- Cancel_Task_Entry_Call (Cancel_Param);
1059 Make_Procedure_Call_Statement (Loc,
1061 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
1062 Parameter_Associations => New_List (
1063 New_Occurrence_Of (Cancel_Param, Loc))));
1068 Append_List_To (Stmts, Additional_Cleanup);
1070 end Build_Cleanup_Statements;
1072 -----------------------------
1073 -- Build_Controlling_Procs --
1074 -----------------------------
1076 procedure Build_Controlling_Procs (Typ : Entity_Id) is
1078 if Is_Array_Type (Typ) then
1079 Build_Array_Deep_Procs (Typ);
1080 else pragma Assert (Is_Record_Type (Typ));
1081 Build_Record_Deep_Procs (Typ);
1083 end Build_Controlling_Procs;
1085 -----------------------------
1086 -- Build_Exception_Handler --
1087 -----------------------------
1089 function Build_Exception_Handler
1090 (Data : Finalization_Exception_Data;
1091 For_Library : Boolean := False) return Node_Id
1094 Proc_To_Call : Entity_Id;
1099 pragma Assert (Present (Data.Raised_Id));
1101 if Exception_Extra_Info
1102 or else (For_Library and not Restricted_Profile)
1104 if Exception_Extra_Info then
1108 -- Get_Current_Excep.all
1111 Make_Function_Call (Data.Loc,
1113 Make_Explicit_Dereference (Data.Loc,
1116 (RTE (RE_Get_Current_Excep), Data.Loc)));
1123 Except := Make_Null (Data.Loc);
1126 if For_Library and then not Restricted_Profile then
1127 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1128 Actuals := New_List (Except);
1131 Proc_To_Call := RTE (RE_Save_Occurrence);
1133 -- The dereference occurs only when Exception_Extra_Info is true,
1134 -- and therefore Except is not null.
1138 New_Occurrence_Of (Data.E_Id, Data.Loc),
1139 Make_Explicit_Dereference (Data.Loc, Except));
1145 -- if not Raised_Id then
1146 -- Raised_Id := True;
1148 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1150 -- Save_Library_Occurrence (Get_Current_Excep.all);
1155 Make_If_Statement (Data.Loc,
1157 Make_Op_Not (Data.Loc,
1158 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1160 Then_Statements => New_List (
1161 Make_Assignment_Statement (Data.Loc,
1162 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1163 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1165 Make_Procedure_Call_Statement (Data.Loc,
1167 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1168 Parameter_Associations => Actuals))));
1173 -- Raised_Id := True;
1176 Make_Assignment_Statement (Data.Loc,
1177 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1178 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1186 Make_Exception_Handler (Data.Loc,
1187 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1188 Statements => Stmts);
1189 end Build_Exception_Handler;
1191 -------------------------------
1192 -- Build_Finalization_Master --
1193 -------------------------------
1195 procedure Build_Finalization_Master
1197 For_Lib_Level : Boolean := False;
1198 For_Private : Boolean := False;
1199 Context_Scope : Entity_Id := Empty;
1200 Insertion_Node : Node_Id := Empty)
1202 procedure Add_Pending_Access_Type
1204 Ptr_Typ : Entity_Id);
1205 -- Add access type Ptr_Typ to the pending access type list for type Typ
1207 -----------------------------
1208 -- Add_Pending_Access_Type --
1209 -----------------------------
1211 procedure Add_Pending_Access_Type
1213 Ptr_Typ : Entity_Id)
1218 if Present (Pending_Access_Types (Typ)) then
1219 List := Pending_Access_Types (Typ);
1221 List := New_Elmt_List;
1222 Set_Pending_Access_Types (Typ, List);
1225 Prepend_Elmt (Ptr_Typ, List);
1226 end Add_Pending_Access_Type;
1230 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1232 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1233 -- A finalization master created for a named access type is associated
1234 -- with the full view (if applicable) as a consequence of freezing. The
1235 -- full view criteria does not apply to anonymous access types because
1236 -- those cannot have a private and a full view.
1238 -- Start of processing for Build_Finalization_Master
1241 -- Nothing to do if the circumstances do not allow for a finalization
1244 if not Allows_Finalization_Master (Typ) then
1247 -- Various machinery such as freezing may have already created a
1248 -- finalization master.
1250 elsif Present (Finalization_Master (Ptr_Typ)) then
1255 Actions : constant List_Id := New_List;
1256 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1257 Fin_Mas_Id : Entity_Id;
1258 Pool_Id : Entity_Id;
1261 -- Source access types use fixed master names since the master is
1262 -- inserted in the same source unit only once. The only exception to
1263 -- this are instances using the same access type as generic actual.
1265 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1267 Make_Defining_Identifier (Loc,
1268 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
1270 -- Internally generated access types use temporaries as their names
1271 -- due to possible collision with identical names coming from other
1275 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1278 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1281 -- <Ptr_Typ>FM : aliased Finalization_Master;
1284 Make_Object_Declaration (Loc,
1285 Defining_Identifier => Fin_Mas_Id,
1286 Aliased_Present => True,
1287 Object_Definition =>
1288 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
1290 if Debug_Generated_Code then
1291 Set_Debug_Info_Needed (Fin_Mas_Id);
1294 -- Set the associated pool and primitive Finalize_Address of the new
1295 -- finalization master.
1297 -- The access type has a user-defined storage pool, use it
1299 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1300 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1302 -- Otherwise the default choice is the global storage pool
1305 Pool_Id := RTE (RE_Global_Pool_Object);
1306 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1310 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1313 Make_Procedure_Call_Statement (Loc,
1315 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
1316 Parameter_Associations => New_List (
1317 New_Occurrence_Of (Fin_Mas_Id, Loc),
1318 Make_Attribute_Reference (Loc,
1319 Prefix => New_Occurrence_Of (Pool_Id, Loc),
1320 Attribute_Name => Name_Unrestricted_Access))));
1322 -- Finalize_Address is not generated in CodePeer mode because the
1323 -- body contains address arithmetic. Skip this step.
1325 if CodePeer_Mode then
1328 -- Associate the Finalize_Address primitive of the designated type
1329 -- with the finalization master of the access type. The designated
1330 -- type must be forzen as Finalize_Address is generated when the
1331 -- freeze node is expanded.
1333 elsif Is_Frozen (Desig_Typ)
1334 and then Present (Finalize_Address (Desig_Typ))
1336 -- The finalization master of an anonymous access type may need
1337 -- to be inserted in a specific place in the tree. For instance:
1341 -- <finalization master of "access Comp_Typ">
1343 -- type Rec_Typ is record
1344 -- Comp : access Comp_Typ;
1347 -- <freeze node for Comp_Typ>
1348 -- <freeze node for Rec_Typ>
1350 -- Due to this oddity, the anonymous access type is stored for
1351 -- later processing (see below).
1353 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
1356 -- Set_Finalize_Address
1357 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1360 Make_Set_Finalize_Address_Call
1362 Ptr_Typ => Ptr_Typ));
1364 -- Otherwise the designated type is either anonymous access or a
1365 -- Taft-amendment type and has not been frozen. Store the access
1366 -- type for later processing (see Freeze_Type).
1369 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1372 -- A finalization master created for an access designating a type
1373 -- with private components is inserted before a context-dependent
1378 -- At this point both the scope of the context and the insertion
1379 -- mode must be known.
1381 pragma Assert (Present (Context_Scope));
1382 pragma Assert (Present (Insertion_Node));
1384 Push_Scope (Context_Scope);
1386 -- Treat use clauses as declarations and insert directly in front
1389 if Nkind (Insertion_Node) in
1390 N_Use_Package_Clause | N_Use_Type_Clause
1392 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1394 Insert_Actions (Insertion_Node, Actions);
1399 -- The finalization master belongs to an access result type related
1400 -- to a build-in-place function call used to initialize a library
1401 -- level object. The master must be inserted in front of the access
1402 -- result type declaration denoted by Insertion_Node.
1404 elsif For_Lib_Level then
1405 pragma Assert (Present (Insertion_Node));
1406 Insert_Actions (Insertion_Node, Actions);
1408 -- Otherwise the finalization master and its initialization become a
1409 -- part of the freeze node.
1412 Append_Freeze_Actions (Ptr_Typ, Actions);
1415 Analyze_List (Actions);
1417 -- When the type the finalization master is being generated for was
1418 -- created to store a 'Old object, then mark it as such so its
1419 -- finalization can be delayed until after postconditions have been
1422 if Stores_Attribute_Old_Prefix (Ptr_Typ) then
1423 Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id);
1426 end Build_Finalization_Master;
1428 ----------------------------
1429 -- Build_Finalizer_Helper --
1430 ----------------------------
1432 procedure Build_Finalizer_Helper
1434 Clean_Stmts : List_Id;
1435 Mark_Id : Entity_Id;
1436 Top_Decls : List_Id;
1437 Defer_Abort : Boolean;
1438 Fin_Id : out Entity_Id;
1439 Finalize_Old_Only : Boolean)
1441 Acts_As_Clean : constant Boolean :=
1444 (Present (Clean_Stmts)
1445 and then Is_Non_Empty_List (Clean_Stmts));
1447 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1448 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1449 For_Package : constant Boolean :=
1450 For_Package_Body or else For_Package_Spec;
1451 Loc : constant Source_Ptr := Sloc (N);
1453 -- NOTE: Local variable declarations are conservative and do not create
1454 -- structures right from the start. Entities and lists are created once
1455 -- it has been established that N has at least one controlled object.
1457 Components_Built : Boolean := False;
1458 -- A flag used to avoid double initialization of entities and lists. If
1459 -- the flag is set then the following variables have been initialized:
1465 Counter_Id : Entity_Id := Empty;
1466 Counter_Val : Nat := 0;
1467 -- Name and value of the state counter
1469 Decls : List_Id := No_List;
1470 -- Declarative region of N (if available). If N is a package declaration
1471 -- Decls denotes the visible declarations.
1473 Finalizer_Data : Finalization_Exception_Data;
1474 -- Data for the exception
1476 Finalizer_Decls : List_Id := No_List;
1477 -- Local variable declarations. This list holds the label declarations
1478 -- of all jump block alternatives as well as the declaration of the
1479 -- local exception occurrence and the raised flag:
1480 -- E : Exception_Occurrence;
1481 -- Raised : Boolean := False;
1482 -- L<counter value> : label;
1484 Finalizer_Insert_Nod : Node_Id := Empty;
1485 -- Insertion point for the finalizer body. Depending on the context
1486 -- (Nkind of N) and the individual grouping of controlled objects, this
1487 -- node may denote a package declaration or body, package instantiation,
1488 -- block statement or a counter update statement.
1490 Finalizer_Stmts : List_Id := No_List;
1491 -- The statement list of the finalizer body. It contains the following:
1493 -- Abort_Defer; -- Added if abort is allowed
1494 -- <call to Prev_At_End> -- Added if exists
1495 -- <cleanup statements> -- Added if Acts_As_Clean
1496 -- <jump block> -- Added if Has_Ctrl_Objs
1497 -- <finalization statements> -- Added if Has_Ctrl_Objs
1498 -- <stack release> -- Added if Mark_Id exists
1499 -- Abort_Undefer; -- Added if abort is allowed
1501 Has_Ctrl_Objs : Boolean := False;
1502 -- A general flag which denotes whether N has at least one controlled
1505 Has_Tagged_Types : Boolean := False;
1506 -- A general flag which indicates whether N has at least one library-
1507 -- level tagged type declaration.
1509 HSS : Node_Id := Empty;
1510 -- The sequence of statements of N (if available)
1512 Jump_Alts : List_Id := No_List;
1513 -- Jump block alternatives. Depending on the value of the state counter,
1514 -- the control flow jumps to a sequence of finalization statements. This
1515 -- list contains the following:
1517 -- when <counter value> =>
1518 -- goto L<counter value>;
1520 Jump_Block_Insert_Nod : Node_Id := Empty;
1521 -- Specific point in the finalizer statements where the jump block is
1524 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1525 -- The last controlled construct encountered when processing the top
1526 -- level lists of N. This can be a nested package, an instantiation or
1527 -- an object declaration.
1529 Prev_At_End : Entity_Id := Empty;
1530 -- The previous at end procedure of the handled statements block of N
1532 Priv_Decls : List_Id := No_List;
1533 -- The private declarations of N if N is a package declaration
1535 Spec_Id : Entity_Id := Empty;
1536 Spec_Decls : List_Id := Top_Decls;
1537 Stmts : List_Id := No_List;
1539 Tagged_Type_Stmts : List_Id := No_List;
1540 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1541 -- tagged types found in N.
1543 -----------------------
1544 -- Local subprograms --
1545 -----------------------
1547 procedure Build_Components;
1548 -- Create all entites and initialize all lists used in the creation of
1551 procedure Create_Finalizer;
1552 -- Create the spec and body of the finalizer and insert them in the
1553 -- proper place in the tree depending on the context.
1555 function New_Finalizer_Name
1556 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id;
1557 -- Create a fully qualified name of a package spec or body finalizer.
1558 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1560 procedure Process_Declarations
1562 Preprocess : Boolean := False;
1563 Top_Level : Boolean := False);
1564 -- Inspect a list of declarations or statements which may contain
1565 -- objects that need finalization. When flag Preprocess is set, the
1566 -- routine will simply count the total number of controlled objects in
1567 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1568 -- when Preprocess is set and if True, the processing is performed for
1569 -- objects in nested package declarations or instances.
1571 procedure Process_Object_Declaration
1573 Has_No_Init : Boolean := False;
1574 Is_Protected : Boolean := False);
1575 -- Generate all the machinery associated with the finalization of a
1576 -- single object. Flag Has_No_Init is used to denote certain contexts
1577 -- where Decl does not have initialization call(s). Flag Is_Protected
1578 -- is set when Decl denotes a simple protected object.
1580 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1581 -- Generate all the code necessary to unregister the external tag of a
1584 ----------------------
1585 -- Build_Components --
1586 ----------------------
1588 procedure Build_Components is
1589 Counter_Decl : Node_Id;
1590 Counter_Typ : Entity_Id;
1591 Counter_Typ_Decl : Node_Id;
1594 pragma Assert (Present (Decls));
1596 -- This routine might be invoked several times when dealing with
1597 -- constructs that have two lists (either two declarative regions
1598 -- or declarations and statements). Avoid double initialization.
1600 if Components_Built then
1604 Components_Built := True;
1606 if Has_Ctrl_Objs then
1608 -- Create entities for the counter, its type, the local exception
1609 -- and the raised flag.
1611 Counter_Id := Make_Temporary (Loc, 'C');
1612 Counter_Typ := Make_Temporary (Loc, 'T');
1614 Finalizer_Decls := New_List;
1616 Build_Object_Declarations
1617 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1619 -- Since the total number of controlled objects is always known,
1620 -- build a subtype of Natural with precise bounds. This allows
1621 -- the backend to optimize the case statement. Generate:
1623 -- subtype Tnn is Natural range 0 .. Counter_Val;
1626 Make_Subtype_Declaration (Loc,
1627 Defining_Identifier => Counter_Typ,
1628 Subtype_Indication =>
1629 Make_Subtype_Indication (Loc,
1630 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1632 Make_Range_Constraint (Loc,
1636 Make_Integer_Literal (Loc, Uint_0),
1638 Make_Integer_Literal (Loc, Counter_Val)))));
1640 -- Generate the declaration of the counter itself:
1642 -- Counter : Integer := 0;
1645 Make_Object_Declaration (Loc,
1646 Defining_Identifier => Counter_Id,
1647 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1648 Expression => Make_Integer_Literal (Loc, 0));
1650 -- Set the type of the counter explicitly to prevent errors when
1651 -- examining object declarations later on.
1653 Set_Etype (Counter_Id, Counter_Typ);
1655 if Debug_Generated_Code then
1656 Set_Debug_Info_Needed (Counter_Id);
1659 -- The counter and its type are inserted before the source
1660 -- declarations of N.
1662 Prepend_To (Decls, Counter_Decl);
1663 Prepend_To (Decls, Counter_Typ_Decl);
1665 -- The counter and its associated type must be manually analyzed
1666 -- since N has already been analyzed. Use the scope of the spec
1667 -- when inserting in a package.
1670 Push_Scope (Spec_Id);
1671 Analyze (Counter_Typ_Decl);
1672 Analyze (Counter_Decl);
1676 Analyze (Counter_Typ_Decl);
1677 Analyze (Counter_Decl);
1680 Jump_Alts := New_List;
1683 -- If the context requires additional cleanup, the finalization
1684 -- machinery is added after the cleanup code.
1686 if Acts_As_Clean then
1687 Finalizer_Stmts := Clean_Stmts;
1688 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1690 Finalizer_Stmts := New_List;
1693 if Has_Tagged_Types then
1694 Tagged_Type_Stmts := New_List;
1696 end Build_Components;
1698 ----------------------
1699 -- Create_Finalizer --
1700 ----------------------
1702 procedure Create_Finalizer is
1703 Body_Id : Entity_Id;
1706 Jump_Block : Node_Id;
1708 Label_Id : Entity_Id;
1711 -- Step 1: Creation of the finalizer name
1713 -- Packages must use a distinct name for their finalizers since the
1714 -- binder will have to generate calls to them by name. The name is
1715 -- of the following form:
1717 -- xx__yy__finalize_[spec|body]
1720 Fin_Id := Make_Defining_Identifier
1721 (Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec));
1722 Set_Has_Qualified_Name (Fin_Id);
1723 Set_Has_Fully_Qualified_Name (Fin_Id);
1725 -- The default name is _finalizer
1728 -- Generation of a finalization procedure exclusively for 'Old
1729 -- interally generated constants requires different name since
1730 -- there will need to be multiple finalization routines in the
1731 -- same scope. See Build_Finalizer for details.
1733 if Finalize_Old_Only then
1735 Make_Defining_Identifier (Loc,
1736 Chars => New_External_Name (Name_uFinalizer_Old));
1739 Make_Defining_Identifier (Loc,
1740 Chars => New_External_Name (Name_uFinalizer));
1743 -- The visibility semantics of AT_END handlers force a strange
1744 -- separation of spec and body for stack-related finalizers:
1746 -- declare : Enclosing_Scope
1747 -- procedure _finalizer;
1749 -- <controlled objects>
1750 -- procedure _finalizer is
1756 -- Both spec and body are within the same construct and scope, but
1757 -- the body is part of the handled sequence of statements. This
1758 -- placement confuses the elaboration mechanism on targets where
1759 -- AT_END handlers are expanded into "when all others" handlers:
1762 -- when all others =>
1763 -- _finalizer; -- appears to require elab checks
1768 -- Since the compiler guarantees that the body of a _finalizer is
1769 -- always inserted in the same construct where the AT_END handler
1770 -- resides, there is no need for elaboration checks.
1772 Set_Kill_Elaboration_Checks (Fin_Id);
1774 -- Inlining the finalizer produces a substantial speedup at -O2.
1775 -- It is inlined by default at -O3. Either way, it is called
1776 -- exactly twice (once on the normal path, and once for
1777 -- exceptions/abort), so this won't bloat the code too much.
1779 Set_Is_Inlined (Fin_Id);
1782 if Debug_Generated_Code then
1783 Set_Debug_Info_Needed (Fin_Id);
1786 -- Step 2: Creation of the finalizer specification
1789 -- procedure Fin_Id;
1792 Make_Subprogram_Declaration (Loc,
1794 Make_Procedure_Specification (Loc,
1795 Defining_Unit_Name => Fin_Id));
1798 Set_Is_Exported (Fin_Id);
1799 Set_Interface_Name (Fin_Id,
1800 Make_String_Literal (Loc,
1801 Strval => Get_Name_String (Chars (Fin_Id))));
1804 -- Step 3: Creation of the finalizer body
1806 -- Has_Ctrl_Objs might be set because of a generic package body having
1807 -- controlled objects. In this case, Jump_Alts may be empty and no
1808 -- case nor goto statements are needed.
1811 and then not Is_Empty_List (Jump_Alts)
1813 -- Add L0, the default destination to the jump block
1815 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1816 Set_Entity (Label_Id,
1817 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1818 Label := Make_Label (Loc, Label_Id);
1823 Prepend_To (Finalizer_Decls,
1824 Make_Implicit_Label_Declaration (Loc,
1825 Defining_Identifier => Entity (Label_Id),
1826 Label_Construct => Label));
1832 Append_To (Jump_Alts,
1833 Make_Case_Statement_Alternative (Loc,
1834 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1835 Statements => New_List (
1836 Make_Goto_Statement (Loc,
1837 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1842 Append_To (Finalizer_Stmts, Label);
1844 -- Create the jump block which controls the finalization flow
1845 -- depending on the value of the state counter.
1848 Make_Case_Statement (Loc,
1849 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1850 Alternatives => Jump_Alts);
1852 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1853 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1855 Prepend_To (Finalizer_Stmts, Jump_Block);
1859 -- Add the library-level tagged type unregistration machinery before
1860 -- the jump block circuitry. This ensures that external tags will be
1861 -- removed even if a finalization exception occurs at some point.
1863 if Has_Tagged_Types then
1864 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1867 -- Add a call to the previous At_End handler if it exists. The call
1868 -- must always precede the jump block.
1870 if Present (Prev_At_End) then
1871 Prepend_To (Finalizer_Stmts,
1872 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1874 -- Clear the At_End handler since we have already generated the
1875 -- proper replacement call for it.
1877 Set_At_End_Proc (HSS, Empty);
1880 -- Release the secondary stack
1882 if Present (Mark_Id) then
1884 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
1887 -- If the context is a build-in-place function, the secondary
1888 -- stack must be released, unless the build-in-place function
1889 -- itself is returning on the secondary stack. Generate:
1891 -- if BIP_Alloc_Form /= Secondary_Stack then
1892 -- SS_Release (Mark_Id);
1895 -- Note that if the function returns on the secondary stack,
1896 -- then the responsibility of reclaiming the space is always
1897 -- left to the caller (recursively if needed).
1899 if Nkind (N) = N_Subprogram_Body then
1901 Spec_Id : constant Entity_Id :=
1902 Unique_Defining_Entity (N);
1903 BIP_SS : constant Boolean :=
1904 Is_Build_In_Place_Function (Spec_Id)
1905 and then Needs_BIP_Alloc_Form (Spec_Id);
1909 Make_If_Statement (Loc,
1914 (Build_In_Place_Formal
1915 (Spec_Id, BIP_Alloc_Form), Loc),
1917 Make_Integer_Literal (Loc,
1919 (BIP_Allocation_Form'Pos
1920 (Secondary_Stack)))),
1922 Then_Statements => New_List (Release));
1927 Append_To (Finalizer_Stmts, Release);
1931 -- Protect the statements with abort defer/undefer. This is only when
1932 -- aborts are allowed and the cleanup statements require deferral or
1933 -- there are controlled objects to be finalized. Note that the abort
1934 -- defer/undefer pair does not require an extra block because each
1935 -- finalization exception is caught in its corresponding finalization
1936 -- block. As a result, the call to Abort_Defer always takes place.
1938 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1939 Prepend_To (Finalizer_Stmts,
1940 Build_Runtime_Call (Loc, RE_Abort_Defer));
1942 Append_To (Finalizer_Stmts,
1943 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1946 -- The local exception does not need to be reraised for library-level
1947 -- finalizers. Note that this action must be carried out after object
1948 -- cleanup, secondary stack release, and abort undeferral. Generate:
1950 -- if Raised and then not Abort then
1951 -- Raise_From_Controlled_Operation (E);
1954 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1955 Append_To (Finalizer_Stmts,
1956 Build_Raise_Statement (Finalizer_Data));
1960 -- procedure Fin_Id is
1961 -- Abort : constant Boolean := Triggered_By_Abort;
1963 -- Abort : constant Boolean := False; -- no abort
1965 -- E : Exception_Occurrence; -- All added if flag
1966 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1972 -- Abort_Defer; -- Added if abort is allowed
1973 -- <call to Prev_At_End> -- Added if exists
1974 -- <cleanup statements> -- Added if Acts_As_Clean
1975 -- <jump block> -- Added if Has_Ctrl_Objs
1976 -- <finalization statements> -- Added if Has_Ctrl_Objs
1977 -- <stack release> -- Added if Mark_Id exists
1978 -- Abort_Undefer; -- Added if abort is allowed
1979 -- <exception propagation> -- Added if Has_Ctrl_Objs
1982 -- Create the body of the finalizer
1984 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1986 if Debug_Generated_Code then
1987 Set_Debug_Info_Needed (Body_Id);
1991 Set_Has_Qualified_Name (Body_Id);
1992 Set_Has_Fully_Qualified_Name (Body_Id);
1996 Make_Subprogram_Body (Loc,
1998 Make_Procedure_Specification (Loc,
1999 Defining_Unit_Name => Body_Id),
2000 Declarations => Finalizer_Decls,
2001 Handled_Statement_Sequence =>
2002 Make_Handled_Sequence_Of_Statements (Loc,
2003 Statements => Finalizer_Stmts));
2005 -- Step 4: Spec and body insertion, analysis
2009 -- If the package spec has private declarations, the finalizer
2010 -- body must be added to the end of the list in order to have
2011 -- visibility of all private controlled objects.
2013 if For_Package_Spec then
2014 if Present (Priv_Decls) then
2015 Append_To (Priv_Decls, Fin_Spec);
2016 Append_To (Priv_Decls, Fin_Body);
2018 Append_To (Decls, Fin_Spec);
2019 Append_To (Decls, Fin_Body);
2022 -- For package bodies, both the finalizer spec and body are
2023 -- inserted at the end of the package declarations.
2026 Append_To (Decls, Fin_Spec);
2027 Append_To (Decls, Fin_Body);
2030 -- Push the name of the package
2032 Push_Scope (Spec_Id);
2040 -- Create the spec for the finalizer. The At_End handler must be
2041 -- able to call the body which resides in a nested structure.
2045 -- procedure Fin_Id; -- Spec
2047 -- <objects and possibly statements>
2048 -- procedure Fin_Id is ... -- Body
2051 -- Fin_Id; -- At_End handler
2054 pragma Assert (Present (Spec_Decls));
2056 -- It maybe possible that we are finalizing 'Old objects which
2057 -- exist in the spec declarations. When this is the case the
2058 -- Finalizer_Insert_Node will come before the end of the
2059 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
2060 -- earlier at the Finalizer_Insert_Nod instead of appending to the
2061 -- end of Spec_Decls to prevent its body appearing before its
2062 -- corresponding spec.
2064 if Present (Finalizer_Insert_Nod)
2065 and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls
2067 Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec);
2068 Finalizer_Insert_Nod := Fin_Spec;
2070 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
2073 Append_To (Spec_Decls, Fin_Spec);
2077 -- When the finalizer acts solely as a cleanup routine, the body
2078 -- is inserted right after the spec.
2080 if Acts_As_Clean and not Has_Ctrl_Objs then
2081 Insert_After (Fin_Spec, Fin_Body);
2083 -- In all other cases the body is inserted after either:
2085 -- 1) The counter update statement of the last controlled object
2086 -- 2) The last top level nested controlled package
2087 -- 3) The last top level controlled instantiation
2090 -- Manually freeze the spec. This is somewhat of a hack because
2091 -- a subprogram is frozen when its body is seen and the freeze
2092 -- node appears right before the body. However, in this case,
2093 -- the spec must be frozen earlier since the At_End handler
2094 -- must be able to call it.
2097 -- procedure Fin_Id; -- Spec
2098 -- [Fin_Id] -- Freeze node
2102 -- Fin_Id; -- At_End handler
2105 Ensure_Freeze_Node (Fin_Id);
2106 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
2107 Set_Is_Frozen (Fin_Id);
2109 -- In the case where the last construct to contain a controlled
2110 -- object is either a nested package, an instantiation or a
2111 -- freeze node, the body must be inserted directly after the
2114 if Nkind (Last_Top_Level_Ctrl_Construct) in
2115 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2117 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
2120 Insert_After (Finalizer_Insert_Nod, Fin_Body);
2123 Analyze (Fin_Body, Suppress => All_Checks);
2126 -- Never consider that the finalizer procedure is enabled Ghost, even
2127 -- when the corresponding unit is Ghost, as this would lead to an
2128 -- an external name with a ___ghost_ prefix that the binder cannot
2129 -- generate, as it has no knowledge of the Ghost status of units.
2131 Set_Is_Checked_Ghost_Entity (Fin_Id, False);
2132 end Create_Finalizer;
2134 ------------------------
2135 -- New_Finalizer_Name --
2136 ------------------------
2138 function New_Finalizer_Name
2139 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id
2141 procedure New_Finalizer_Name (Id : Entity_Id);
2142 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2143 -- has a non-standard scope, process the scope first.
2145 ------------------------
2146 -- New_Finalizer_Name --
2147 ------------------------
2149 procedure New_Finalizer_Name (Id : Entity_Id) is
2151 if Scope (Id) = Standard_Standard then
2152 Get_Name_String (Chars (Id));
2155 New_Finalizer_Name (Scope (Id));
2156 Add_Str_To_Name_Buffer ("__");
2157 Get_Name_String_And_Append (Chars (Id));
2159 end New_Finalizer_Name;
2161 -- Start of processing for New_Finalizer_Name
2164 -- Create the fully qualified name of the enclosing scope
2166 New_Finalizer_Name (Spec_Id);
2169 -- __finalize_[spec|body]
2171 Add_Str_To_Name_Buffer ("__finalize_");
2174 Add_Str_To_Name_Buffer ("spec");
2176 Add_Str_To_Name_Buffer ("body");
2180 end New_Finalizer_Name;
2182 --------------------------
2183 -- Process_Declarations --
2184 --------------------------
2186 procedure Process_Declarations
2188 Preprocess : Boolean := False;
2189 Top_Level : Boolean := False)
2194 Obj_Typ : Entity_Id;
2195 Pack_Id : Entity_Id;
2199 Old_Counter_Val : Nat;
2200 -- This variable is used to determine whether a nested package or
2201 -- instance contains at least one controlled object.
2203 procedure Processing_Actions
2204 (Has_No_Init : Boolean := False;
2205 Is_Protected : Boolean := False);
2206 -- Depending on the mode of operation of Process_Declarations, either
2207 -- increment the controlled object counter, set the controlled object
2208 -- flag and store the last top level construct or process the current
2209 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2210 -- the current declaration may not have initialization proc(s). Flag
2211 -- Is_Protected should be set when the current declaration denotes a
2212 -- simple protected object.
2214 ------------------------
2215 -- Processing_Actions --
2216 ------------------------
2218 procedure Processing_Actions
2219 (Has_No_Init : Boolean := False;
2220 Is_Protected : Boolean := False)
2223 -- Library-level tagged type
2225 if Nkind (Decl) = N_Full_Type_Declaration then
2227 Has_Tagged_Types := True;
2229 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2230 Last_Top_Level_Ctrl_Construct := Decl;
2234 Process_Tagged_Type_Declaration (Decl);
2237 -- Controlled object declaration
2241 Counter_Val := Counter_Val + 1;
2242 Has_Ctrl_Objs := True;
2244 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2245 Last_Top_Level_Ctrl_Construct := Decl;
2249 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2252 end Processing_Actions;
2254 -- Start of processing for Process_Declarations
2257 if No (Decls) or else Is_Empty_List (Decls) then
2261 -- Process all declarations in reverse order
2263 Decl := Last_Non_Pragma (Decls);
2264 while Present (Decl) loop
2265 -- Depending on the value of flag Finalize_Old_Only we determine
2266 -- which objects get finalized as part of the current finalizer
2269 -- When True, only temporaries capturing the value of attribute
2270 -- 'Old are finalized and all other cases are ignored.
2272 -- When False, temporary objects used to capture the value of 'Old
2273 -- are ignored and all others are considered.
2275 if Finalize_Old_Only
2276 xor (Nkind (Decl) = N_Object_Declaration
2277 and then Stores_Attribute_Old_Prefix
2278 (Defining_Identifier (Decl)))
2282 -- Library-level tagged types
2284 elsif Nkind (Decl) = N_Full_Type_Declaration then
2285 Typ := Defining_Identifier (Decl);
2287 -- Ignored Ghost types do not need any cleanup actions because
2288 -- they will not appear in the final tree.
2290 if Is_Ignored_Ghost_Entity (Typ) then
2293 elsif Is_Tagged_Type (Typ)
2294 and then Is_Library_Level_Entity (Typ)
2295 and then Convention (Typ) = Convention_Ada
2296 and then Present (Access_Disp_Table (Typ))
2297 and then RTE_Available (RE_Register_Tag)
2298 and then not Is_Abstract_Type (Typ)
2299 and then not No_Run_Time_Mode
2304 -- Regular object declarations
2306 elsif Nkind (Decl) = N_Object_Declaration then
2307 Obj_Id := Defining_Identifier (Decl);
2308 Obj_Typ := Base_Type (Etype (Obj_Id));
2309 Expr := Expression (Decl);
2311 -- Bypass any form of processing for objects which have their
2312 -- finalization disabled. This applies only to objects at the
2315 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2318 -- Finalization of transient objects are treated separately in
2319 -- order to handle sensitive cases. These include:
2321 -- * Aggregate expansion
2322 -- * If, case, and expression with actions expansion
2323 -- * Transient scopes
2325 -- If one of those contexts has marked the transient object as
2326 -- ignored, do not generate finalization actions for it.
2328 elsif Is_Finalized_Transient (Obj_Id)
2329 or else Is_Ignored_Transient (Obj_Id)
2333 -- Ignored Ghost objects do not need any cleanup actions
2334 -- because they will not appear in the final tree.
2336 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2339 -- The object is of the form:
2340 -- Obj : [constant] Typ [:= Expr];
2342 -- Do not process tag-to-class-wide conversions because they do
2343 -- not yield an object. Do not process the incomplete view of a
2344 -- deferred constant. Note that an object initialized by means
2345 -- of a build-in-place function call may appear as a deferred
2346 -- constant after expansion activities. These kinds of objects
2347 -- must be finalized.
2349 elsif not Is_Imported (Obj_Id)
2350 and then Needs_Finalization (Obj_Typ)
2351 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
2352 and then not (Ekind (Obj_Id) = E_Constant
2353 and then not Has_Completion (Obj_Id)
2354 and then No (BIP_Initialization_Call (Obj_Id)))
2358 -- The object is of the form:
2359 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2361 -- Obj : Access_Typ :=
2362 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2364 elsif Is_Access_Type (Obj_Typ)
2365 and then Needs_Finalization
2366 (Available_View (Designated_Type (Obj_Typ)))
2367 and then Present (Expr)
2369 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2371 (Is_Non_BIP_Func_Call (Expr)
2372 and then not Is_Related_To_Func_Return (Obj_Id)))
2374 Processing_Actions (Has_No_Init => True);
2376 -- Processing for "hook" objects generated for transient
2377 -- objects declared inside an Expression_With_Actions.
2379 elsif Is_Access_Type (Obj_Typ)
2380 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2381 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2382 N_Object_Declaration
2384 Processing_Actions (Has_No_Init => True);
2386 -- Process intermediate results of an if expression with one
2387 -- of the alternatives using a controlled function call.
2389 elsif Is_Access_Type (Obj_Typ)
2390 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2391 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2392 N_Defining_Identifier
2393 and then Present (Expr)
2394 and then Nkind (Expr) = N_Null
2396 Processing_Actions (Has_No_Init => True);
2398 -- Simple protected objects which use type System.Tasking.
2399 -- Protected_Objects.Protection to manage their locks should
2400 -- be treated as controlled since they require manual cleanup.
2401 -- The only exception is illustrated in the following example:
2404 -- type Ctrl is new Controlled ...
2405 -- procedure Finalize (Obj : in out Ctrl);
2409 -- package body Pkg is
2410 -- protected Prot is
2411 -- procedure Do_Something (Obj : in out Ctrl);
2414 -- protected body Prot is
2415 -- procedure Do_Something (Obj : in out Ctrl) is ...
2418 -- procedure Finalize (Obj : in out Ctrl) is
2420 -- Prot.Do_Something (Obj);
2424 -- Since for the most part entities in package bodies depend on
2425 -- those in package specs, Prot's lock should be cleaned up
2426 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2427 -- This act however attempts to invoke Do_Something and fails
2428 -- because the lock has disappeared.
2430 elsif Ekind (Obj_Id) = E_Variable
2431 and then not In_Library_Level_Package_Body (Obj_Id)
2432 and then (Is_Simple_Protected_Type (Obj_Typ)
2433 or else Has_Simple_Protected_Object (Obj_Typ))
2435 Processing_Actions (Is_Protected => True);
2438 -- Specific cases of object renamings
2440 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2441 Obj_Id := Defining_Identifier (Decl);
2442 Obj_Typ := Base_Type (Etype (Obj_Id));
2444 -- Bypass any form of processing for objects which have their
2445 -- finalization disabled. This applies only to objects at the
2448 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2451 -- Ignored Ghost object renamings do not need any cleanup
2452 -- actions because they will not appear in the final tree.
2454 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2457 -- Return object of a build-in-place function. This case is
2458 -- recognized and marked by the expansion of an extended return
2459 -- statement (see Expand_N_Extended_Return_Statement).
2461 elsif Needs_Finalization (Obj_Typ)
2462 and then Is_Return_Object (Obj_Id)
2463 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2465 Processing_Actions (Has_No_Init => True);
2467 -- Detect a case where a source object has been initialized by
2468 -- a controlled function call or another object which was later
2469 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2471 -- Obj1 : CW_Type := Src_Obj;
2472 -- Obj2 : CW_Type := Function_Call (...);
2474 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2475 -- Tmp : ... := Function_Call (...)'reference;
2476 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2478 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
2479 Processing_Actions (Has_No_Init => True);
2482 -- Inspect the freeze node of an access-to-controlled type and
2483 -- look for a delayed finalization master. This case arises when
2484 -- the freeze actions are inserted at a later time than the
2485 -- expansion of the context. Since Build_Finalizer is never called
2486 -- on a single construct twice, the master will be ultimately
2487 -- left out and never finalized. This is also needed for freeze
2488 -- actions of designated types themselves, since in some cases the
2489 -- finalization master is associated with a designated type's
2490 -- freeze node rather than that of the access type (see handling
2491 -- for freeze actions in Build_Finalization_Master).
2493 elsif Nkind (Decl) = N_Freeze_Entity
2494 and then Present (Actions (Decl))
2496 Typ := Entity (Decl);
2498 -- Freeze nodes for ignored Ghost types do not need cleanup
2499 -- actions because they will never appear in the final tree.
2501 if Is_Ignored_Ghost_Entity (Typ) then
2504 elsif (Is_Access_Object_Type (Typ)
2505 and then Needs_Finalization
2506 (Available_View (Designated_Type (Typ))))
2507 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2509 Old_Counter_Val := Counter_Val;
2511 -- Freeze nodes are considered to be identical to packages
2512 -- and blocks in terms of nesting. The difference is that
2513 -- a finalization master created inside the freeze node is
2514 -- at the same nesting level as the node itself.
2516 Process_Declarations (Actions (Decl), Preprocess);
2518 -- The freeze node contains a finalization master
2522 and then No (Last_Top_Level_Ctrl_Construct)
2523 and then Counter_Val > Old_Counter_Val
2525 Last_Top_Level_Ctrl_Construct := Decl;
2529 -- Nested package declarations, avoid generics
2531 elsif Nkind (Decl) = N_Package_Declaration then
2532 Pack_Id := Defining_Entity (Decl);
2533 Spec := Specification (Decl);
2535 -- Do not inspect an ignored Ghost package because all code
2536 -- found within will not appear in the final tree.
2538 if Is_Ignored_Ghost_Entity (Pack_Id) then
2541 elsif Ekind (Pack_Id) /= E_Generic_Package then
2542 Old_Counter_Val := Counter_Val;
2543 Process_Declarations
2544 (Private_Declarations (Spec), Preprocess);
2545 Process_Declarations
2546 (Visible_Declarations (Spec), Preprocess);
2548 -- Either the visible or the private declarations contain a
2549 -- controlled object. The nested package declaration is the
2550 -- last such construct.
2554 and then No (Last_Top_Level_Ctrl_Construct)
2555 and then Counter_Val > Old_Counter_Val
2557 Last_Top_Level_Ctrl_Construct := Decl;
2561 -- Call the xxx__finalize_body procedure of a library level
2562 -- package instantiation if the body contains finalization
2565 if Present (Generic_Parent (Spec))
2566 and then Is_Library_Level_Entity (Pack_Id)
2567 and then Present (Body_Entity (Generic_Parent (Spec)))
2573 P := Parent (Body_Entity (Generic_Parent (Spec)));
2575 and then Nkind (P) /= N_Package_Body
2581 Old_Counter_Val := Counter_Val;
2582 Process_Declarations (Declarations (P), Preprocess);
2584 -- Note that we are processing the generic body
2585 -- template and not the actually instantiation
2586 -- (which is generated too late for us to process
2587 -- it), so there is no need to update in particular
2588 -- to update Last_Top_Level_Ctrl_Construct here.
2590 if Counter_Val > Old_Counter_Val then
2591 Counter_Val := Old_Counter_Val;
2592 Set_Has_Controlled_Component (Pack_Id);
2597 elsif Has_Controlled_Component (Pack_Id) then
2599 -- We import the xxx__finalize_body routine since the
2600 -- generic body will be instantiated later.
2603 Id : constant Node_Id :=
2604 Make_Defining_Identifier (Loc,
2605 New_Finalizer_Name (Defining_Unit_Name (Spec),
2606 For_Spec => False));
2609 Set_Has_Qualified_Name (Id);
2610 Set_Has_Fully_Qualified_Name (Id);
2611 Set_Is_Imported (Id);
2612 Set_Has_Completion (Id);
2613 Set_Interface_Name (Id,
2614 Make_String_Literal (Loc,
2615 Strval => Get_Name_String (Chars (Id))));
2617 Append_New_To (Finalizer_Stmts,
2618 Make_Subprogram_Declaration (Loc,
2619 Make_Procedure_Specification (Loc,
2620 Defining_Unit_Name => Id)));
2621 Append_To (Finalizer_Stmts,
2622 Make_Procedure_Call_Statement (Loc,
2623 Name => New_Occurrence_Of (Id, Loc)));
2628 -- Nested package bodies, avoid generics
2630 elsif Nkind (Decl) = N_Package_Body then
2632 -- Do not inspect an ignored Ghost package body because all
2633 -- code found within will not appear in the final tree.
2635 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2638 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
2640 Old_Counter_Val := Counter_Val;
2641 Process_Declarations (Declarations (Decl), Preprocess);
2643 -- The nested package body is the last construct to contain
2644 -- a controlled object.
2648 and then No (Last_Top_Level_Ctrl_Construct)
2649 and then Counter_Val > Old_Counter_Val
2651 Last_Top_Level_Ctrl_Construct := Decl;
2655 -- Handle a rare case caused by a controlled transient object
2656 -- created as part of a record init proc. The variable is wrapped
2657 -- in a block, but the block is not associated with a transient
2660 elsif Nkind (Decl) = N_Block_Statement
2661 and then Inside_Init_Proc
2663 Old_Counter_Val := Counter_Val;
2665 if Present (Handled_Statement_Sequence (Decl)) then
2666 Process_Declarations
2667 (Statements (Handled_Statement_Sequence (Decl)),
2671 Process_Declarations (Declarations (Decl), Preprocess);
2673 -- Either the declaration or statement list of the block has a
2674 -- controlled object.
2678 and then No (Last_Top_Level_Ctrl_Construct)
2679 and then Counter_Val > Old_Counter_Val
2681 Last_Top_Level_Ctrl_Construct := Decl;
2684 -- Handle the case where the original context has been wrapped in
2685 -- a block to avoid interference between exception handlers and
2686 -- At_End handlers. Treat the block as transparent and process its
2689 elsif Nkind (Decl) = N_Block_Statement
2690 and then Is_Finalization_Wrapper (Decl)
2692 if Present (Handled_Statement_Sequence (Decl)) then
2693 Process_Declarations
2694 (Statements (Handled_Statement_Sequence (Decl)),
2698 Process_Declarations (Declarations (Decl), Preprocess);
2701 Prev_Non_Pragma (Decl);
2703 end Process_Declarations;
2705 --------------------------------
2706 -- Process_Object_Declaration --
2707 --------------------------------
2709 procedure Process_Object_Declaration
2711 Has_No_Init : Boolean := False;
2712 Is_Protected : Boolean := False)
2714 Loc : constant Source_Ptr := Sloc (Decl);
2715 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2717 Init_Typ : Entity_Id;
2718 -- The initialization type of the related object declaration. Note
2719 -- that this is not necessarily the same type as Obj_Typ because of
2720 -- possible type derivations.
2722 Obj_Typ : Entity_Id;
2723 -- The type of the related object declaration
2725 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2726 -- Func_Id denotes a build-in-place function. Generate the following
2729 -- if BIPallocfrom > Secondary_Stack'Pos
2730 -- and then BIPfinalizationmaster /= null
2733 -- type Ptr_Typ is access Obj_Typ;
2734 -- for Ptr_Typ'Storage_Pool
2735 -- use Base_Pool (BIPfinalizationmaster);
2737 -- Free (Ptr_Typ (Temp));
2741 -- Obj_Typ is the type of the current object, Temp is the original
2742 -- allocation which Obj_Id renames.
2744 procedure Find_Last_Init
2745 (Last_Init : out Node_Id;
2746 Body_Insert : out Node_Id);
2747 -- Find the last initialization call related to object declaration
2748 -- Decl. Last_Init denotes the last initialization call which follows
2749 -- Decl. Body_Insert denotes a node where the finalizer body could be
2750 -- potentially inserted after (if blocks are involved).
2752 -----------------------------
2753 -- Build_BIP_Cleanup_Stmts --
2754 -----------------------------
2756 function Build_BIP_Cleanup_Stmts
2757 (Func_Id : Entity_Id) return Node_Id
2759 Decls : constant List_Id := New_List;
2760 Fin_Mas_Id : constant Entity_Id :=
2761 Build_In_Place_Formal
2762 (Func_Id, BIP_Finalization_Master);
2763 Func_Typ : constant Entity_Id := Etype (Func_Id);
2764 Temp_Id : constant Entity_Id :=
2765 Entity (Prefix (Name (Parent (Obj_Id))));
2769 Free_Stmt : Node_Id;
2770 Pool_Id : Entity_Id;
2771 Ptr_Typ : Entity_Id;
2775 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2777 Pool_Id := Make_Temporary (Loc, 'P');
2780 Make_Object_Renaming_Declaration (Loc,
2781 Defining_Identifier => Pool_Id,
2783 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2785 Make_Explicit_Dereference (Loc,
2787 Make_Function_Call (Loc,
2789 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2790 Parameter_Associations => New_List (
2791 Make_Explicit_Dereference (Loc,
2793 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2795 -- Create an access type which uses the storage pool of the
2796 -- caller's finalization master.
2799 -- type Ptr_Typ is access Func_Typ;
2801 Ptr_Typ := Make_Temporary (Loc, 'P');
2804 Make_Full_Type_Declaration (Loc,
2805 Defining_Identifier => Ptr_Typ,
2807 Make_Access_To_Object_Definition (Loc,
2808 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2810 -- Perform minor decoration in order to set the master and the
2811 -- storage pool attributes.
2813 Set_Ekind (Ptr_Typ, E_Access_Type);
2814 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2815 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2817 if Debug_Generated_Code then
2818 Set_Debug_Info_Needed (Pool_Id);
2821 -- Create an explicit free statement. Note that the free uses the
2822 -- caller's pool expressed as a renaming.
2825 Make_Free_Statement (Loc,
2827 Unchecked_Convert_To (Ptr_Typ,
2828 New_Occurrence_Of (Temp_Id, Loc)));
2830 Set_Storage_Pool (Free_Stmt, Pool_Id);
2832 -- Create a block to house the dummy type and the instantiation as
2833 -- well as to perform the cleanup the temporary.
2839 -- Free (Ptr_Typ (Temp_Id));
2843 Make_Block_Statement (Loc,
2844 Declarations => Decls,
2845 Handled_Statement_Sequence =>
2846 Make_Handled_Sequence_Of_Statements (Loc,
2847 Statements => New_List (Free_Stmt)));
2850 -- if BIPfinalizationmaster /= null then
2854 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2855 Right_Opnd => Make_Null (Loc));
2857 -- For constrained or tagged results escalate the condition to
2858 -- include the allocation format. Generate:
2860 -- if BIPallocform > Secondary_Stack'Pos
2861 -- and then BIPfinalizationmaster /= null
2864 if not Is_Constrained (Func_Typ)
2865 or else Is_Tagged_Type (Func_Typ)
2868 Alloc : constant Entity_Id :=
2869 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2875 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2877 Make_Integer_Literal (Loc,
2879 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2881 Right_Opnd => Cond);
2891 Make_If_Statement (Loc,
2893 Then_Statements => New_List (Free_Blk));
2894 end Build_BIP_Cleanup_Stmts;
2896 --------------------
2897 -- Find_Last_Init --
2898 --------------------
2900 procedure Find_Last_Init
2901 (Last_Init : out Node_Id;
2902 Body_Insert : out Node_Id)
2904 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2905 -- Find the last initialization call within the statements of
2908 function Is_Init_Call (N : Node_Id) return Boolean;
2909 -- Determine whether node N denotes one of the initialization
2910 -- procedures of types Init_Typ or Obj_Typ.
2912 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2913 -- Obtain the next statement which follows list member Stmt while
2914 -- ignoring artifacts related to access-before-elaboration checks.
2916 -----------------------------
2917 -- Find_Last_Init_In_Block --
2918 -----------------------------
2920 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2921 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2925 -- Examine the individual statements of the block in reverse to
2926 -- locate the last initialization call.
2928 if Present (HSS) and then Present (Statements (HSS)) then
2929 Stmt := Last (Statements (HSS));
2930 while Present (Stmt) loop
2932 -- Peek inside nested blocks in case aborts are allowed
2934 if Nkind (Stmt) = N_Block_Statement then
2935 return Find_Last_Init_In_Block (Stmt);
2937 elsif Is_Init_Call (Stmt) then
2946 end Find_Last_Init_In_Block;
2952 function Is_Init_Call (N : Node_Id) return Boolean is
2953 function Is_Init_Proc_Of
2954 (Subp_Id : Entity_Id;
2955 Typ : Entity_Id) return Boolean;
2956 -- Determine whether subprogram Subp_Id is a valid init proc of
2959 ---------------------
2960 -- Is_Init_Proc_Of --
2961 ---------------------
2963 function Is_Init_Proc_Of
2964 (Subp_Id : Entity_Id;
2965 Typ : Entity_Id) return Boolean
2967 Deep_Init : Entity_Id := Empty;
2968 Prim_Init : Entity_Id := Empty;
2969 Type_Init : Entity_Id := Empty;
2972 -- Obtain all possible initialization routines of the
2973 -- related type and try to match the subprogram entity
2974 -- against one of them.
2978 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2980 -- Primitive Initialize
2982 if Is_Controlled (Typ) then
2983 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2985 if Present (Prim_Init) then
2986 Prim_Init := Ultimate_Alias (Prim_Init);
2990 -- Type initialization routine
2992 if Has_Non_Null_Base_Init_Proc (Typ) then
2993 Type_Init := Base_Init_Proc (Typ);
2997 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2999 (Present (Prim_Init) and then Subp_Id = Prim_Init)
3001 (Present (Type_Init) and then Subp_Id = Type_Init);
3002 end Is_Init_Proc_Of;
3006 Call_Id : Entity_Id;
3008 -- Start of processing for Is_Init_Call
3011 if Nkind (N) = N_Procedure_Call_Statement
3012 and then Nkind (Name (N)) = N_Identifier
3014 Call_Id := Entity (Name (N));
3016 -- Consider both the type of the object declaration and its
3017 -- related initialization type.
3020 Is_Init_Proc_Of (Call_Id, Init_Typ)
3022 Is_Init_Proc_Of (Call_Id, Obj_Typ);
3028 -----------------------------
3029 -- Next_Suitable_Statement --
3030 -----------------------------
3032 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
3036 -- Skip call markers and Program_Error raises installed by the
3039 Result := Next (Stmt);
3040 while Present (Result) loop
3041 exit when Nkind (Result) not in
3042 N_Call_Marker | N_Raise_Program_Error;
3048 end Next_Suitable_Statement;
3056 Deep_Init_Found : Boolean := False;
3057 -- A flag set when a call to [Deep_]Initialize has been found
3059 -- Start of processing for Find_Last_Init
3063 Body_Insert := Empty;
3065 -- Object renamings and objects associated with controlled
3066 -- function results do not require initialization.
3072 Stmt := Next_Suitable_Statement (Decl);
3074 -- For an object with suppressed initialization, we check whether
3075 -- there is in fact no initialization expression. If there is not,
3076 -- then this is an object declaration that has been turned into a
3077 -- different object declaration that calls the build-in-place
3078 -- function in a 'Reference attribute, as in "F(...)'Reference".
3079 -- We search for that later object declaration, so that the
3080 -- Inc_Decl will be inserted after the call. Otherwise, if the
3081 -- call raises an exception, we will finalize the (uninitialized)
3082 -- object, which is wrong.
3084 if No_Initialization (Decl) then
3085 if No (Expression (Last_Init)) then
3088 exit when No (Last_Init);
3089 exit when Nkind (Last_Init) = N_Object_Declaration
3090 and then Nkind (Expression (Last_Init)) = N_Reference
3091 and then Nkind (Prefix (Expression (Last_Init))) =
3093 and then Is_Expanded_Build_In_Place_Call
3094 (Prefix (Expression (Last_Init)));
3100 -- In all other cases the initialization calls follow the related
3101 -- object. The general structure of object initialization built by
3102 -- routine Default_Initialize_Object is as follows:
3104 -- [begin -- aborts allowed
3106 -- Type_Init_Proc (Obj);
3107 -- [begin] -- exceptions allowed
3108 -- Deep_Initialize (Obj);
3109 -- [exception -- exceptions allowed
3111 -- Deep_Finalize (Obj, Self => False);
3114 -- [at end -- aborts allowed
3118 -- When aborts are allowed, the initialization calls are housed
3121 elsif Nkind (Stmt) = N_Block_Statement then
3122 Last_Init := Find_Last_Init_In_Block (Stmt);
3123 Body_Insert := Stmt;
3125 -- Otherwise the initialization calls follow the related object
3128 pragma Assert (Present (Stmt));
3130 Stmt_2 := Next_Suitable_Statement (Stmt);
3132 -- Check for an optional call to Deep_Initialize which may
3133 -- appear within a block depending on whether the object has
3134 -- controlled components.
3136 if Present (Stmt_2) then
3137 if Nkind (Stmt_2) = N_Block_Statement then
3138 Call := Find_Last_Init_In_Block (Stmt_2);
3140 if Present (Call) then
3141 Deep_Init_Found := True;
3143 Body_Insert := Stmt_2;
3146 elsif Is_Init_Call (Stmt_2) then
3147 Deep_Init_Found := True;
3148 Last_Init := Stmt_2;
3149 Body_Insert := Last_Init;
3153 -- If the object lacks a call to Deep_Initialize, then it must
3154 -- have a call to its related type init proc.
3156 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
3158 Body_Insert := Last_Init;
3166 Count_Ins : Node_Id;
3168 Fin_Stmts : List_Id := No_List;
3171 Label_Id : Entity_Id;
3174 -- Start of processing for Process_Object_Declaration
3177 -- Handle the object type and the reference to the object
3179 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
3180 Obj_Typ := Base_Type (Etype (Obj_Id));
3183 if Is_Access_Type (Obj_Typ) then
3184 Obj_Typ := Directly_Designated_Type (Obj_Typ);
3185 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
3187 elsif Is_Concurrent_Type (Obj_Typ)
3188 and then Present (Corresponding_Record_Type (Obj_Typ))
3190 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
3191 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3193 elsif Is_Private_Type (Obj_Typ)
3194 and then Present (Full_View (Obj_Typ))
3196 Obj_Typ := Full_View (Obj_Typ);
3197 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3199 elsif Obj_Typ /= Base_Type (Obj_Typ) then
3200 Obj_Typ := Base_Type (Obj_Typ);
3201 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3208 Set_Etype (Obj_Ref, Obj_Typ);
3210 -- Handle the initialization type of the object declaration
3212 Init_Typ := Obj_Typ;
3214 if Is_Private_Type (Init_Typ)
3215 and then Present (Full_View (Init_Typ))
3217 Init_Typ := Full_View (Init_Typ);
3219 elsif Is_Untagged_Derivation (Init_Typ) then
3220 Init_Typ := Root_Type (Init_Typ);
3227 -- Set a new value for the state counter and insert the statement
3228 -- after the object declaration. Generate:
3230 -- Counter := <value>;
3233 Make_Assignment_Statement (Loc,
3234 Name => New_Occurrence_Of (Counter_Id, Loc),
3235 Expression => Make_Integer_Literal (Loc, Counter_Val));
3237 -- Insert the counter after all initialization has been done. The
3238 -- place of insertion depends on the context.
3240 if Ekind (Obj_Id) in E_Constant | E_Variable then
3242 -- The object is initialized by a build-in-place function call.
3243 -- The counter insertion point is after the function call.
3245 if Present (BIP_Initialization_Call (Obj_Id)) then
3246 Count_Ins := BIP_Initialization_Call (Obj_Id);
3249 -- The object is initialized by an aggregate. Insert the counter
3250 -- after the last aggregate assignment.
3252 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
3253 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
3256 -- In all other cases the counter is inserted after the last call
3257 -- to either [Deep_]Initialize or the type-specific init proc.
3260 Find_Last_Init (Count_Ins, Body_Ins);
3263 -- In all other cases the counter is inserted after the last call to
3264 -- either [Deep_]Initialize or the type-specific init proc.
3267 Find_Last_Init (Count_Ins, Body_Ins);
3270 -- If the Initialize function is null or trivial, the call will have
3271 -- been replaced with a null statement, in which case place counter
3272 -- declaration after object declaration itself.
3274 if No (Count_Ins) then
3278 Insert_After (Count_Ins, Inc_Decl);
3281 -- If the current declaration is the last in the list, the finalizer
3282 -- body needs to be inserted after the set counter statement for the
3283 -- current object declaration. This is complicated by the fact that
3284 -- the set counter statement may appear in abort deferred block. In
3285 -- that case, the proper insertion place is after the block.
3287 if No (Finalizer_Insert_Nod) then
3289 -- Insertion after an abort deferred block
3291 if Present (Body_Ins) then
3292 Finalizer_Insert_Nod := Body_Ins;
3294 Finalizer_Insert_Nod := Inc_Decl;
3298 -- Create the associated label with this object, generate:
3300 -- L<counter> : label;
3303 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
3305 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
3306 Label := Make_Label (Loc, Label_Id);
3308 Prepend_To (Finalizer_Decls,
3309 Make_Implicit_Label_Declaration (Loc,
3310 Defining_Identifier => Entity (Label_Id),
3311 Label_Construct => Label));
3313 -- Create the associated jump with this object, generate:
3315 -- when <counter> =>
3318 Prepend_To (Jump_Alts,
3319 Make_Case_Statement_Alternative (Loc,
3320 Discrete_Choices => New_List (
3321 Make_Integer_Literal (Loc, Counter_Val)),
3322 Statements => New_List (
3323 Make_Goto_Statement (Loc,
3324 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
3326 -- Insert the jump destination, generate:
3330 Append_To (Finalizer_Stmts, Label);
3332 -- Disable warnings on Obj_Id. This works around an issue where GCC
3333 -- is not able to detect that Obj_Id is protected by a counter and
3334 -- emits spurious warnings.
3336 if not Comes_From_Source (Obj_Id) then
3337 Set_Warnings_Off (Obj_Id);
3340 -- Processing for simple protected objects. Such objects require
3341 -- manual finalization of their lock managers.
3343 if Is_Protected then
3344 if Is_Simple_Protected_Type (Obj_Typ) then
3345 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3347 if Present (Fin_Call) then
3348 Fin_Stmts := New_List (Fin_Call);
3351 elsif Has_Simple_Protected_Object (Obj_Typ) then
3352 if Is_Record_Type (Obj_Typ) then
3353 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3354 elsif Is_Array_Type (Obj_Typ) then
3355 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3361 -- System.Tasking.Protected_Objects.Finalize_Protection
3369 if Present (Fin_Stmts) and then Exceptions_OK then
3370 Fin_Stmts := New_List (
3371 Make_Block_Statement (Loc,
3372 Handled_Statement_Sequence =>
3373 Make_Handled_Sequence_Of_Statements (Loc,
3374 Statements => Fin_Stmts,
3376 Exception_Handlers => New_List (
3377 Make_Exception_Handler (Loc,
3378 Exception_Choices => New_List (
3379 Make_Others_Choice (Loc)),
3381 Statements => New_List (
3382 Make_Null_Statement (Loc)))))));
3385 -- Processing for regular controlled objects
3390 -- [Deep_]Finalize (Obj);
3393 -- when Id : others =>
3394 -- if not Raised then
3396 -- Save_Occurrence (E, Id);
3405 -- Guard against a missing [Deep_]Finalize when the object type
3406 -- was not properly frozen.
3408 if No (Fin_Call) then
3409 Fin_Call := Make_Null_Statement (Loc);
3412 -- For CodePeer, the exception handlers normally generated here
3413 -- generate complex flowgraphs which result in capacity problems.
3414 -- Omitting these handlers for CodePeer is justified as follows:
3416 -- If a handler is dead, then omitting it is surely ok
3418 -- If a handler is live, then CodePeer should flag the
3419 -- potentially-exception-raising construct that causes it
3420 -- to be live. That is what we are interested in, not what
3421 -- happens after the exception is raised.
3423 if Exceptions_OK and not CodePeer_Mode then
3424 Fin_Stmts := New_List (
3425 Make_Block_Statement (Loc,
3426 Handled_Statement_Sequence =>
3427 Make_Handled_Sequence_Of_Statements (Loc,
3428 Statements => New_List (Fin_Call),
3430 Exception_Handlers => New_List (
3431 Build_Exception_Handler
3432 (Finalizer_Data, For_Package)))));
3434 -- When exception handlers are prohibited, the finalization call
3435 -- appears unprotected. Any exception raised during finalization
3436 -- will bypass the circuitry which ensures the cleanup of all
3437 -- remaining objects.
3440 Fin_Stmts := New_List (Fin_Call);
3443 -- If we are dealing with a return object of a build-in-place
3444 -- function, generate the following cleanup statements:
3446 -- if BIPallocfrom > Secondary_Stack'Pos
3447 -- and then BIPfinalizationmaster /= null
3450 -- type Ptr_Typ is access Obj_Typ;
3451 -- for Ptr_Typ'Storage_Pool use
3452 -- Base_Pool (BIPfinalizationmaster.all).all;
3454 -- Free (Ptr_Typ (Temp));
3458 -- The generated code effectively detaches the temporary from the
3459 -- caller finalization master and deallocates the object.
3461 if Is_Return_Object (Obj_Id) then
3463 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
3465 if Is_Build_In_Place_Function (Func_Id)
3466 and then Needs_BIP_Finalization_Master (Func_Id)
3468 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3473 if Ekind (Obj_Id) in E_Constant | E_Variable
3474 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3476 -- Temporaries created for the purpose of "exporting" a
3477 -- transient object out of an Expression_With_Actions (EWA)
3478 -- need guards. The following illustrates the usage of such
3481 -- Access_Typ : access [all] Obj_Typ;
3482 -- Temp : Access_Typ := null;
3483 -- <Counter> := ...;
3486 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3487 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3489 -- Temp := Ctrl_Trans'Unchecked_Access;
3492 -- The finalization machinery does not process EWA nodes as
3493 -- this may lead to premature finalization of expressions. Note
3494 -- that Temp is marked as being properly initialized regardless
3495 -- of whether the initialization of Ctrl_Trans succeeded. Since
3496 -- a failed initialization may leave Temp with a value of null,
3497 -- add a guard to handle this case:
3499 -- if Obj /= null then
3500 -- <object finalization statements>
3503 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3504 N_Object_Declaration
3506 Fin_Stmts := New_List (
3507 Make_If_Statement (Loc,
3510 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3511 Right_Opnd => Make_Null (Loc)),
3512 Then_Statements => Fin_Stmts));
3514 -- Return objects use a flag to aid in processing their
3515 -- potential finalization when the enclosing function fails
3516 -- to return properly. Generate:
3519 -- <object finalization statements>
3523 Fin_Stmts := New_List (
3524 Make_If_Statement (Loc,
3529 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3531 Then_Statements => Fin_Stmts));
3536 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3538 -- Since the declarations are examined in reverse, the state counter
3539 -- must be decremented in order to keep with the true position of
3542 Counter_Val := Counter_Val - 1;
3543 end Process_Object_Declaration;
3545 -------------------------------------
3546 -- Process_Tagged_Type_Declaration --
3547 -------------------------------------
3549 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3550 Typ : constant Entity_Id := Defining_Identifier (Decl);
3551 DT_Ptr : constant Entity_Id :=
3552 Node (First_Elmt (Access_Disp_Table (Typ)));
3555 -- Ada.Tags.Unregister_Tag (<Typ>P);
3557 Append_To (Tagged_Type_Stmts,
3558 Make_Procedure_Call_Statement (Loc,
3560 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3561 Parameter_Associations => New_List (
3562 New_Occurrence_Of (DT_Ptr, Loc))));
3563 end Process_Tagged_Type_Declaration;
3565 -- Start of processing for Build_Finalizer_Helper
3570 -- Do not perform this expansion in SPARK mode because it is not
3573 if GNATprove_Mode then
3577 -- Step 1: Extract all lists which may contain controlled objects or
3578 -- library-level tagged types.
3580 if For_Package_Spec then
3581 Decls := Visible_Declarations (Specification (N));
3582 Priv_Decls := Private_Declarations (Specification (N));
3584 -- Retrieve the package spec id
3586 Spec_Id := Defining_Unit_Name (Specification (N));
3588 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3589 Spec_Id := Defining_Identifier (Spec_Id);
3592 -- Accept statement, block, entry body, package body, protected body,
3593 -- subprogram body or task body.
3596 Decls := Declarations (N);
3597 HSS := Handled_Statement_Sequence (N);
3599 if Present (HSS) then
3600 if Present (Statements (HSS)) then
3601 Stmts := Statements (HSS);
3604 if Present (At_End_Proc (HSS)) then
3605 Prev_At_End := At_End_Proc (HSS);
3609 -- Retrieve the package spec id for package bodies
3611 if For_Package_Body then
3612 Spec_Id := Corresponding_Spec (N);
3616 -- Do not process nested packages since those are handled by the
3617 -- enclosing scope's finalizer. Do not process non-expanded package
3618 -- instantiations since those will be re-analyzed and re-expanded.
3622 (not Is_Library_Level_Entity (Spec_Id)
3624 -- Nested packages are considered to be library level entities,
3625 -- but do not need to be processed separately. True library level
3626 -- packages have a scope value of 1.
3628 or else Scope_Depth_Value (Spec_Id) /= Uint_1
3629 or else (Is_Generic_Instance (Spec_Id)
3630 and then Package_Instantiation (Spec_Id) /= N))
3632 -- Still need to process package body instantiations which may
3633 -- contain objects requiring finalization.
3637 and then Is_Library_Level_Entity (Spec_Id)
3638 and then Is_Generic_Instance (Spec_Id))
3643 -- Step 2: Object [pre]processing
3647 -- Preprocess the visible declarations now in order to obtain the
3648 -- correct number of controlled object by the time the private
3649 -- declarations are processed.
3651 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3653 -- From all the possible contexts, only package specifications may
3654 -- have private declarations.
3656 if For_Package_Spec then
3657 Process_Declarations
3658 (Priv_Decls, Preprocess => True, Top_Level => True);
3661 -- The current context may lack controlled objects, but require some
3662 -- other form of completion (task termination for instance). In such
3663 -- cases, the finalizer must be created and carry the additional
3666 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3670 -- The preprocessing has determined that the context has controlled
3671 -- objects or library-level tagged types.
3673 if Has_Ctrl_Objs or Has_Tagged_Types then
3675 -- Private declarations are processed first in order to preserve
3676 -- possible dependencies between public and private objects.
3678 if For_Package_Spec then
3679 Process_Declarations (Priv_Decls);
3682 Process_Declarations (Decls);
3688 -- Preprocess both declarations and statements
3690 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3691 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3693 -- At this point it is known that N has controlled objects. Ensure
3694 -- that N has a declarative list since the finalizer spec will be
3697 if Has_Ctrl_Objs and then No (Decls) then
3698 Set_Declarations (N, New_List);
3699 Decls := Declarations (N);
3700 Spec_Decls := Decls;
3703 -- The current context may lack controlled objects, but require some
3704 -- other form of completion (task termination for instance). In such
3705 -- cases, the finalizer must be created and carry the additional
3708 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3712 if Has_Ctrl_Objs or Has_Tagged_Types then
3713 Process_Declarations (Stmts);
3714 Process_Declarations (Decls);
3718 -- Step 3: Finalizer creation
3720 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3723 end Build_Finalizer_Helper;
3725 --------------------------
3726 -- Build_Finalizer_Call --
3727 --------------------------
3729 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3730 Is_Prot_Body : constant Boolean :=
3731 Nkind (N) = N_Subprogram_Body
3732 and then Is_Protected_Subprogram_Body (N);
3733 -- Determine whether N denotes the protected version of a subprogram
3734 -- which belongs to a protected type.
3736 Loc : constant Source_Ptr := Sloc (N);
3740 -- Do not perform this expansion in SPARK mode because we do not create
3741 -- finalizers in the first place.
3743 if GNATprove_Mode then
3747 -- The At_End handler should have been assimilated by the finalizer
3749 HSS := Handled_Statement_Sequence (N);
3750 pragma Assert (No (At_End_Proc (HSS)));
3752 -- If the construct to be cleaned up is a protected subprogram body, the
3753 -- finalizer call needs to be associated with the block which wraps the
3754 -- unprotected version of the subprogram. The following illustrates this
3757 -- procedure Prot_SubpP is
3758 -- procedure finalizer is
3760 -- Service_Entries (Prot_Obj);
3767 -- Prot_SubpN (Prot_Obj);
3773 if Is_Prot_Body then
3774 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3776 -- An At_End handler and regular exception handlers cannot coexist in
3777 -- the same statement sequence. Wrap the original statements in a block.
3779 elsif Present (Exception_Handlers (HSS)) then
3781 End_Lab : constant Node_Id := End_Label (HSS);
3786 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3788 Set_Handled_Statement_Sequence (N,
3789 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3791 HSS := Handled_Statement_Sequence (N);
3792 Set_End_Label (HSS, End_Lab);
3796 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3798 -- Attach reference to finalizer to tree, for LLVM use
3800 Set_Parent (At_End_Proc (HSS), HSS);
3802 Analyze (At_End_Proc (HSS));
3803 Expand_At_End_Handler (HSS, Empty);
3804 end Build_Finalizer_Call;
3806 ---------------------
3807 -- Build_Finalizer --
3808 ---------------------
3810 procedure Build_Finalizer
3812 Clean_Stmts : List_Id;
3813 Mark_Id : Entity_Id;
3814 Top_Decls : List_Id;
3815 Defer_Abort : Boolean;
3816 Fin_Id : out Entity_Id)
3818 Def_Ent : constant Entity_Id := Unique_Defining_Entity (N);
3819 Loc : constant Source_Ptr := Sloc (N);
3821 -- Declarations used for the creation of _finalization_controller
3823 Fin_Old_Id : Entity_Id := Empty;
3824 Fin_Controller_Id : Entity_Id := Empty;
3825 Fin_Controller_Decls : List_Id;
3826 Fin_Controller_Stmts : List_Id;
3827 Fin_Controller_Body : Node_Id := Empty;
3828 Fin_Controller_Spec : Node_Id := Empty;
3829 Postconditions_Call : Node_Id := Empty;
3831 -- Defining identifiers for local objects used to store exception info
3833 Raised_Post_Exception_Id : Entity_Id := Empty;
3834 Raised_Finalization_Exception_Id : Entity_Id := Empty;
3835 Saved_Exception_Id : Entity_Id := Empty;
3837 -- Start of processing for Build_Finalizer
3840 -- Create the general finalization routine
3842 Build_Finalizer_Helper
3844 Clean_Stmts => Clean_Stmts,
3846 Top_Decls => Top_Decls,
3847 Defer_Abort => Defer_Abort,
3849 Finalize_Old_Only => False);
3851 -- When postconditions are present, expansion gets much more complicated
3852 -- due to both the fact that they must be called after finalization and
3853 -- that finalization of 'Old objects must occur after the postconditions
3856 -- Additionally, exceptions between general finalization and 'Old
3857 -- finalization must be propagated correctly and exceptions which happen
3858 -- during _postconditions need to be saved and reraised after
3859 -- finalization of 'Old objects.
3863 -- Postcond_Enabled := False;
3865 -- procedure _finalization_controller is
3867 -- -- Exception capturing and tracking
3869 -- Saved_Exception : Exception_Occurrence;
3870 -- Raised_Post_Exception : Boolean := False;
3871 -- Raised_Finalization_Exception : Boolean := False;
3873 -- -- Start of processing for _finalization_controller
3876 -- -- Perform general finalization
3882 -- -- Save the exception
3884 -- Raised_Finalization_Exception := True;
3886 -- (Saved_Exception, Get_Current_Excep.all);
3889 -- -- Perform postcondition checks after general finalization, but
3890 -- -- before finalization of 'Old related objects.
3892 -- if not Raised_Finalization_Exception
3893 -- and then Return_Success_For_Postcond
3896 -- -- Re-enable postconditions and check them
3898 -- Postcond_Enabled := True;
3899 -- _postconditions [(Result_Obj_For_Postcond[.all])];
3902 -- -- Save the exception
3904 -- Raised_Post_Exception := True;
3906 -- (Saved_Exception, Get_Current_Excep.all);
3910 -- -- Finally finalize 'Old related objects
3916 -- -- Reraise the previous finalization error if there is
3919 -- if Raised_Finalization_Exception then
3920 -- Reraise_Occurrence (Saved_Exception);
3923 -- -- Otherwise, reraise the current one
3928 -- -- Reraise any saved exception
3930 -- if Raised_Finalization_Exception
3931 -- or else Raised_Post_Exception
3933 -- Reraise_Occurrence (Saved_Exception);
3935 -- end _finalization_controller;
3937 if Nkind (N) = N_Subprogram_Body
3938 and then Present (Postconditions_Proc (Def_Ent))
3940 Fin_Controller_Stmts := New_List;
3941 Fin_Controller_Decls := New_List;
3943 -- Build the 'Old finalizer
3945 Build_Finalizer_Helper
3947 Clean_Stmts => Empty_List,
3949 Top_Decls => Top_Decls,
3950 Defer_Abort => Defer_Abort,
3951 Fin_Id => Fin_Old_Id,
3952 Finalize_Old_Only => True);
3954 -- Create local declarations for _finalization_controller needed for
3955 -- saving exceptions.
3959 -- Saved_Exception : Exception_Occurrence;
3960 -- Raised_Post_Exception : Boolean := False;
3961 -- Raised_Finalization_Exception : Boolean := False;
3963 Saved_Exception_Id := Make_Temporary (Loc, 'S');
3964 Raised_Post_Exception_Id := Make_Temporary (Loc, 'P');
3965 Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F');
3967 Append_List_To (Fin_Controller_Decls, New_List (
3968 Make_Object_Declaration (Loc,
3969 Defining_Identifier => Saved_Exception_Id,
3970 Object_Definition =>
3971 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)),
3972 Make_Object_Declaration (Loc,
3973 Defining_Identifier => Raised_Post_Exception_Id,
3974 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3975 Expression => New_Occurrence_Of (Standard_False, Loc)),
3976 Make_Object_Declaration (Loc,
3977 Defining_Identifier => Raised_Finalization_Exception_Id,
3978 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3979 Expression => New_Occurrence_Of (Standard_False, Loc))));
3981 -- Call _finalizer and save any exceptions which occur
3989 -- Raised_Finalization_Exception := True;
3991 -- (Saved_Exception, Get_Current_Excep.all);
3994 if Present (Fin_Id) then
3995 Append_To (Fin_Controller_Stmts,
3996 Make_Block_Statement (Loc,
3997 Handled_Statement_Sequence =>
3998 Make_Handled_Sequence_Of_Statements (Loc,
3999 Statements => New_List (
4000 Make_Procedure_Call_Statement (Loc,
4001 Name => New_Occurrence_Of (Fin_Id, Loc))),
4002 Exception_Handlers => New_List (
4003 Make_Exception_Handler (Loc,
4004 Exception_Choices => New_List (
4005 Make_Others_Choice (Loc)),
4006 Statements => New_List (
4007 Make_Assignment_Statement (Loc,
4010 (Raised_Finalization_Exception_Id, Loc),
4012 New_Occurrence_Of (Standard_True, Loc)),
4013 Make_Procedure_Call_Statement (Loc,
4016 (RTE (RE_Save_Occurrence), Loc),
4017 Parameter_Associations => New_List (
4019 (Saved_Exception_Id, Loc),
4020 Make_Explicit_Dereference (Loc,
4022 Make_Function_Call (Loc,
4024 Make_Explicit_Dereference (Loc,
4027 (RTE (RE_Get_Current_Excep),
4031 -- Create the call to postconditions based on the kind of the current
4032 -- subprogram, and the type of the Result_Obj_For_Postcond.
4036 -- _postconditions (Result_Obj_For_Postcond[.all]);
4042 if Ekind (Def_Ent) = E_Procedure then
4043 Postconditions_Call :=
4044 Make_Procedure_Call_Statement (Loc,
4047 (Postconditions_Proc (Def_Ent), Loc));
4049 Postconditions_Call :=
4050 Make_Procedure_Call_Statement (Loc,
4053 (Postconditions_Proc (Def_Ent), Loc),
4054 Parameter_Associations => New_List (
4055 (if Is_Elementary_Type (Etype (Def_Ent)) then
4057 (Get_Result_Object_For_Postcond
4060 Make_Explicit_Dereference (Loc,
4062 (Get_Result_Object_For_Postcond
4063 (Def_Ent), Loc)))));
4066 -- Call _postconditions when no general finalization exceptions have
4067 -- occured taking care to enable the postconditions and save any
4068 -- exception occurrences.
4072 -- if not Raised_Finalization_Exception
4073 -- and then Return_Success_For_Postcond
4076 -- Postcond_Enabled := True;
4077 -- _postconditions [(Result_Obj_For_Postcond[.all])];
4080 -- Raised_Post_Exception := True;
4082 -- (Saved_Exception, Get_Current_Excep.all);
4086 Append_To (Fin_Controller_Stmts,
4087 Make_If_Statement (Loc,
4094 (Raised_Finalization_Exception_Id, Loc)),
4097 (Get_Return_Success_For_Postcond (Def_Ent), Loc)),
4098 Then_Statements => New_List (
4099 Make_Block_Statement (Loc,
4100 Handled_Statement_Sequence =>
4101 Make_Handled_Sequence_Of_Statements (Loc,
4102 Statements => New_List (
4103 Make_Assignment_Statement (Loc,
4106 (Get_Postcond_Enabled (Def_Ent), Loc),
4109 (Standard_True, Loc)),
4110 Postconditions_Call),
4111 Exception_Handlers => New_List (
4112 Make_Exception_Handler (Loc,
4113 Exception_Choices => New_List (
4114 Make_Others_Choice (Loc)),
4115 Statements => New_List (
4116 Make_Assignment_Statement (Loc,
4119 (Raised_Post_Exception_Id, Loc),
4121 New_Occurrence_Of (Standard_True, Loc)),
4122 Make_Procedure_Call_Statement (Loc,
4125 (RTE (RE_Save_Occurrence), Loc),
4126 Parameter_Associations => New_List (
4128 (Saved_Exception_Id, Loc),
4129 Make_Explicit_Dereference (Loc,
4131 Make_Function_Call (Loc,
4133 Make_Explicit_Dereference (Loc,
4136 (RTE (RE_Get_Current_Excep),
4139 -- Call _finalizer_old and reraise any exception that occurred during
4140 -- initial finalization within the exception handler. Otherwise,
4141 -- propagate the current exception.
4149 -- if Raised_Finalization_Exception then
4150 -- Reraise_Occurrence (Saved_Exception);
4155 if Present (Fin_Old_Id) then
4156 Append_To (Fin_Controller_Stmts,
4157 Make_Block_Statement (Loc,
4158 Handled_Statement_Sequence =>
4159 Make_Handled_Sequence_Of_Statements (Loc,
4160 Statements => New_List (
4161 Make_Procedure_Call_Statement (Loc,
4162 Name => New_Occurrence_Of (Fin_Old_Id, Loc))),
4163 Exception_Handlers => New_List (
4164 Make_Exception_Handler (Loc,
4165 Exception_Choices => New_List (
4166 Make_Others_Choice (Loc)),
4167 Statements => New_List (
4168 Make_If_Statement (Loc,
4171 (Raised_Finalization_Exception_Id, Loc),
4172 Then_Statements => New_List (
4173 Make_Procedure_Call_Statement (Loc,
4176 (RTE (RE_Reraise_Occurrence), Loc),
4177 Parameter_Associations => New_List (
4179 (Saved_Exception_Id, Loc))))),
4180 Make_Raise_Statement (Loc)))))));
4183 -- Once finalization is complete reraise any pending exceptions
4187 -- if Raised_Post_Exception
4188 -- or else Raised_Finalization_Exception
4190 -- Reraise_Occurrence (Saved_Exception);
4193 Append_To (Fin_Controller_Stmts,
4194 Make_If_Statement (Loc,
4199 (Raised_Post_Exception_Id, Loc),
4202 (Raised_Finalization_Exception_Id, Loc)),
4203 Then_Statements => New_List (
4204 Make_Procedure_Call_Statement (Loc,
4206 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4207 Parameter_Associations => New_List (
4209 (Saved_Exception_Id, Loc))))));
4211 -- Make the finalization controller subprogram body and declaration.
4214 -- procedure _finalization_controller;
4216 -- procedure _finalization_controller is
4218 -- [Fin_Controller_Stmts];
4221 Fin_Controller_Id :=
4222 Make_Defining_Identifier (Loc,
4223 Chars => New_External_Name (Name_uFinalization_Controller));
4225 Fin_Controller_Spec :=
4226 Make_Subprogram_Declaration (Loc,
4228 Make_Procedure_Specification (Loc,
4229 Defining_Unit_Name => Fin_Controller_Id));
4231 Fin_Controller_Body :=
4232 Make_Subprogram_Body (Loc,
4234 Make_Procedure_Specification (Loc,
4235 Defining_Unit_Name =>
4236 Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))),
4237 Declarations => Fin_Controller_Decls,
4238 Handled_Statement_Sequence =>
4239 Make_Handled_Sequence_Of_Statements (Loc,
4240 Statements => Fin_Controller_Stmts));
4242 -- Disable _postconditions calls which get generated before return
4243 -- statements to delay their evaluation until after finalization.
4245 -- This is done by way of the local Postcond_Enabled object which is
4246 -- initially assigned to True - we then create an assignment within
4247 -- the subprogram's declaration to make it False and assign it back
4248 -- to True before _postconditions is called within
4249 -- _finalization_controller.
4253 -- Postcond_Enable := False;
4255 Append_To (Top_Decls,
4256 Make_Assignment_Statement (Loc,
4259 (Get_Postcond_Enabled (Def_Ent), Loc),
4262 (Standard_False, Loc)));
4264 -- Add the subprogram to the list of declarations an analyze it
4266 Append_To (Top_Decls, Fin_Controller_Spec);
4267 Analyze (Fin_Controller_Spec);
4268 Insert_After (Fin_Controller_Spec, Fin_Controller_Body);
4269 Analyze (Fin_Controller_Body, Suppress => All_Checks);
4271 -- Return the finalization controller as the result Fin_Id
4273 Fin_Id := Fin_Controller_Id;
4275 end Build_Finalizer;
4277 ---------------------
4278 -- Build_Late_Proc --
4279 ---------------------
4281 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
4283 for Final_Prim in Name_Of'Range loop
4284 if Name_Of (Final_Prim) = Nam then
4287 (Prim => Final_Prim,
4289 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
4292 end Build_Late_Proc;
4294 -------------------------------
4295 -- Build_Object_Declarations --
4296 -------------------------------
4298 procedure Build_Object_Declarations
4299 (Data : out Finalization_Exception_Data;
4302 For_Package : Boolean := False)
4307 -- This variable captures an unused dummy internal entity, see the
4308 -- comment associated with its use.
4311 pragma Assert (Decls /= No_List);
4313 -- Always set the proper location as it may be needed even when
4314 -- exception propagation is forbidden.
4318 if Restriction_Active (No_Exception_Propagation) then
4319 Data.Abort_Id := Empty;
4321 Data.Raised_Id := Empty;
4325 Data.Raised_Id := Make_Temporary (Loc, 'R');
4327 -- In certain scenarios, finalization can be triggered by an abort. If
4328 -- the finalization itself fails and raises an exception, the resulting
4329 -- Program_Error must be supressed and replaced by an abort signal. In
4330 -- order to detect this scenario, save the state of entry into the
4331 -- finalization code.
4333 -- This is not needed for library-level finalizers as they are called by
4334 -- the environment task and cannot be aborted.
4336 if not For_Package then
4337 if Abort_Allowed then
4338 Data.Abort_Id := Make_Temporary (Loc, 'A');
4341 -- Abort_Id : constant Boolean := <A_Expr>;
4344 Make_Object_Declaration (Loc,
4345 Defining_Identifier => Data.Abort_Id,
4346 Constant_Present => True,
4347 Object_Definition =>
4348 New_Occurrence_Of (Standard_Boolean, Loc),
4350 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
4352 -- Abort is not required
4355 -- Generate a dummy entity to ensure that the internal symbols are
4356 -- in sync when a unit is compiled with and without aborts.
4358 Dummy := Make_Temporary (Loc, 'A');
4359 Data.Abort_Id := Empty;
4362 -- Library-level finalizers
4365 Data.Abort_Id := Empty;
4368 if Exception_Extra_Info then
4369 Data.E_Id := Make_Temporary (Loc, 'E');
4372 -- E_Id : Exception_Occurrence;
4375 Make_Object_Declaration (Loc,
4376 Defining_Identifier => Data.E_Id,
4377 Object_Definition =>
4378 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
4379 Set_No_Initialization (Decl);
4381 Append_To (Decls, Decl);
4388 -- Raised_Id : Boolean := False;
4391 Make_Object_Declaration (Loc,
4392 Defining_Identifier => Data.Raised_Id,
4393 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
4394 Expression => New_Occurrence_Of (Standard_False, Loc)));
4396 if Debug_Generated_Code then
4397 Set_Debug_Info_Needed (Data.Raised_Id);
4399 end Build_Object_Declarations;
4401 ---------------------------
4402 -- Build_Raise_Statement --
4403 ---------------------------
4405 function Build_Raise_Statement
4406 (Data : Finalization_Exception_Data) return Node_Id
4412 -- Standard run-time use the specialized routine
4413 -- Raise_From_Controlled_Operation.
4415 if Exception_Extra_Info
4416 and then RTE_Available (RE_Raise_From_Controlled_Operation)
4419 Make_Procedure_Call_Statement (Data.Loc,
4422 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
4423 Parameter_Associations =>
4424 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
4426 -- Restricted run-time: exception messages are not supported and hence
4427 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
4432 Make_Raise_Program_Error (Data.Loc,
4433 Reason => PE_Finalize_Raised_Exception);
4438 -- Raised_Id and then not Abort_Id
4442 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
4444 if Present (Data.Abort_Id) then
4445 Expr := Make_And_Then (Data.Loc,
4448 Make_Op_Not (Data.Loc,
4449 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
4454 -- if Raised_Id and then not Abort_Id then
4455 -- Raise_From_Controlled_Operation (E_Id);
4457 -- raise Program_Error; -- restricted runtime
4461 Make_If_Statement (Data.Loc,
4463 Then_Statements => New_List (Stmt));
4464 end Build_Raise_Statement;
4466 -----------------------------
4467 -- Build_Record_Deep_Procs --
4468 -----------------------------
4470 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
4474 (Prim => Initialize_Case,
4476 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
4478 if not Is_Limited_View (Typ) then
4481 (Prim => Adjust_Case,
4483 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
4486 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
4487 -- suppressed since these routine will not be used.
4489 if not Restriction_Active (No_Finalization) then
4492 (Prim => Finalize_Case,
4494 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
4496 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
4498 if not CodePeer_Mode then
4501 (Prim => Address_Case,
4503 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
4506 end Build_Record_Deep_Procs;
4512 function Cleanup_Array
4515 Typ : Entity_Id) return List_Id
4517 Loc : constant Source_Ptr := Sloc (N);
4518 Index_List : constant List_Id := New_List;
4520 function Free_Component return List_Id;
4521 -- Generate the code to finalize the task or protected subcomponents
4522 -- of a single component of the array.
4524 function Free_One_Dimension (Dim : Int) return List_Id;
4525 -- Generate a loop over one dimension of the array
4527 --------------------
4528 -- Free_Component --
4529 --------------------
4531 function Free_Component return List_Id is
4532 Stmts : List_Id := New_List;
4534 C_Typ : constant Entity_Id := Component_Type (Typ);
4537 -- Component type is known to contain tasks or protected objects
4540 Make_Indexed_Component (Loc,
4541 Prefix => Duplicate_Subexpr_No_Checks (Obj),
4542 Expressions => Index_List);
4544 Set_Etype (Tsk, C_Typ);
4546 if Is_Task_Type (C_Typ) then
4547 Append_To (Stmts, Cleanup_Task (N, Tsk));
4549 elsif Is_Simple_Protected_Type (C_Typ) then
4550 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
4552 elsif Is_Record_Type (C_Typ) then
4553 Stmts := Cleanup_Record (N, Tsk, C_Typ);
4555 elsif Is_Array_Type (C_Typ) then
4556 Stmts := Cleanup_Array (N, Tsk, C_Typ);
4562 ------------------------
4563 -- Free_One_Dimension --
4564 ------------------------
4566 function Free_One_Dimension (Dim : Int) return List_Id is
4570 if Dim > Number_Dimensions (Typ) then
4571 return Free_Component;
4573 -- Here we generate the required loop
4576 Index := Make_Temporary (Loc, 'J');
4577 Append (New_Occurrence_Of (Index, Loc), Index_List);
4580 Make_Implicit_Loop_Statement (N,
4581 Identifier => Empty,
4583 Make_Iteration_Scheme (Loc,
4584 Loop_Parameter_Specification =>
4585 Make_Loop_Parameter_Specification (Loc,
4586 Defining_Identifier => Index,
4587 Discrete_Subtype_Definition =>
4588 Make_Attribute_Reference (Loc,
4589 Prefix => Duplicate_Subexpr (Obj),
4590 Attribute_Name => Name_Range,
4591 Expressions => New_List (
4592 Make_Integer_Literal (Loc, Dim))))),
4593 Statements => Free_One_Dimension (Dim + 1)));
4595 end Free_One_Dimension;
4597 -- Start of processing for Cleanup_Array
4600 return Free_One_Dimension (1);
4603 --------------------
4604 -- Cleanup_Record --
4605 --------------------
4607 function Cleanup_Record
4610 Typ : Entity_Id) return List_Id
4612 Loc : constant Source_Ptr := Sloc (N);
4613 Stmts : constant List_Id := New_List;
4614 U_Typ : constant Entity_Id := Underlying_Type (Typ);
4620 if Has_Discriminants (U_Typ)
4621 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
4622 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
4625 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
4627 -- For now, do not attempt to free a component that may appear in a
4628 -- variant, and instead issue a warning. Doing this "properly" would
4629 -- require building a case statement and would be quite a mess. Note
4630 -- that the RM only requires that free "work" for the case of a task
4631 -- access value, so already we go way beyond this in that we deal
4632 -- with the array case and non-discriminated record cases.
4635 ("task/protected object in variant record will not be freed??", N);
4636 return New_List (Make_Null_Statement (Loc));
4639 Comp := First_Component (U_Typ);
4640 while Present (Comp) loop
4641 if Has_Task (Etype (Comp))
4642 or else Has_Simple_Protected_Object (Etype (Comp))
4645 Make_Selected_Component (Loc,
4646 Prefix => Duplicate_Subexpr_No_Checks (Obj),
4647 Selector_Name => New_Occurrence_Of (Comp, Loc));
4648 Set_Etype (Tsk, Etype (Comp));
4650 if Is_Task_Type (Etype (Comp)) then
4651 Append_To (Stmts, Cleanup_Task (N, Tsk));
4653 elsif Is_Simple_Protected_Type (Etype (Comp)) then
4654 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
4656 elsif Is_Record_Type (Etype (Comp)) then
4658 -- Recurse, by generating the prefix of the argument to the
4659 -- eventual cleanup call.
4661 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
4663 elsif Is_Array_Type (Etype (Comp)) then
4664 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
4668 Next_Component (Comp);
4674 ------------------------------
4675 -- Cleanup_Protected_Object --
4676 ------------------------------
4678 function Cleanup_Protected_Object
4680 Ref : Node_Id) return Node_Id
4682 Loc : constant Source_Ptr := Sloc (N);
4685 -- For restricted run-time libraries (Ravenscar), tasks are
4686 -- non-terminating, and protected objects can only appear at library
4687 -- level, so we do not want finalization of protected objects.
4689 if Restricted_Profile then
4694 Make_Procedure_Call_Statement (Loc,
4696 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
4697 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4699 end Cleanup_Protected_Object;
4705 function Cleanup_Task
4707 Ref : Node_Id) return Node_Id
4709 Loc : constant Source_Ptr := Sloc (N);
4712 -- For restricted run-time libraries (Ravenscar), tasks are
4713 -- non-terminating and they can only appear at library level,
4714 -- so we do not want finalization of task objects.
4716 if Restricted_Profile then
4721 Make_Procedure_Call_Statement (Loc,
4723 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
4724 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4728 --------------------------------------
4729 -- Check_Unnesting_Elaboration_Code --
4730 --------------------------------------
4732 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
4733 Loc : constant Source_Ptr := Sloc (N);
4734 Block_Elab_Proc : Entity_Id := Empty;
4736 procedure Set_Block_Elab_Proc;
4737 -- Create a defining identifier for a procedure that will replace
4738 -- a block with nested subprograms (unless it has already been created,
4739 -- in which case this is a no-op).
4741 procedure Set_Block_Elab_Proc is
4743 if No (Block_Elab_Proc) then
4745 Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I'));
4747 end Set_Block_Elab_Proc;
4749 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
4750 -- Find entities in the elaboration code of a library package body that
4751 -- contain or represent a subprogram body. A body can appear within a
4752 -- block or a loop or can appear by itself if generated for an object
4753 -- declaration that involves controlled actions. The first such entity
4754 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4755 -- that will be used to reset the scopes of all entities that become
4756 -- local to the new elaboration procedure. This is needed for subsequent
4757 -- unnesting actions, which depend on proper setting of the Scope links
4758 -- to determine the nesting level of each subprogram.
4760 -----------------------
4761 -- Find_Local_Scope --
4762 -----------------------
4764 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
4771 while Present (Stat) loop
4772 case Nkind (Stat) is
4773 when N_Block_Statement =>
4774 if Present (Identifier (Stat)) then
4775 Id := Entity (Identifier (Stat));
4777 -- The Scope of this block needs to be reset to the new
4778 -- procedure if the block contains nested subprograms.
4780 if Present (Id) and then Contains_Subprogram (Id) then
4781 Set_Block_Elab_Proc;
4782 Set_Scope (Id, Block_Elab_Proc);
4786 when N_Loop_Statement =>
4787 Id := Entity (Identifier (Stat));
4789 if Present (Id) and then Contains_Subprogram (Id) then
4790 if Scope (Id) = Current_Scope then
4791 Set_Block_Elab_Proc;
4792 Set_Scope (Id, Block_Elab_Proc);
4796 -- We traverse the loop's statements as well, which may
4797 -- include other block (etc.) statements that need to have
4798 -- their Scope set to Block_Elab_Proc. (Is this really the
4799 -- case, or do such nested blocks refer to the loop scope
4800 -- rather than the loop's enclosing scope???.)
4802 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
4804 when N_If_Statement =>
4805 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
4806 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
4808 Node := First (Elsif_Parts (Stat));
4809 while Present (Node) loop
4810 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node));
4814 when N_Case_Statement =>
4815 Node := First (Alternatives (Stat));
4816 while Present (Node) loop
4817 Reset_Scopes_To_Block_Elab_Proc (Statements (Node));
4821 -- Reset the Scope of a subprogram occurring at the top level
4823 when N_Subprogram_Body =>
4824 Id := Defining_Entity (Stat);
4826 Set_Block_Elab_Proc;
4827 Set_Scope (Id, Block_Elab_Proc);
4835 end Reset_Scopes_To_Block_Elab_Proc;
4839 H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4840 Elab_Body : Node_Id;
4841 Elab_Call : Node_Id;
4843 -- Start of processing for Check_Unnesting_Elaboration_Code
4846 if Present (H_Seq) then
4847 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
4849 -- There may be subprograms declared in the exception handlers
4850 -- of the current body.
4852 if Present (Exception_Handlers (H_Seq)) then
4854 Handler : Node_Id := First (Exception_Handlers (H_Seq));
4856 while Present (Handler) loop
4857 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
4864 if Present (Block_Elab_Proc) then
4866 Make_Subprogram_Body (Loc,
4868 Make_Procedure_Specification (Loc,
4869 Defining_Unit_Name => Block_Elab_Proc),
4870 Declarations => New_List,
4871 Handled_Statement_Sequence =>
4872 Relocate_Node (Handled_Statement_Sequence (N)));
4875 Make_Procedure_Call_Statement (Loc,
4876 Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
4878 Append_To (Declarations (N), Elab_Body);
4879 Analyze (Elab_Body);
4880 Set_Has_Nested_Subprogram (Block_Elab_Proc);
4882 Set_Handled_Statement_Sequence (N,
4883 Make_Handled_Sequence_Of_Statements (Loc,
4884 Statements => New_List (Elab_Call)));
4886 Analyze (Elab_Call);
4888 -- Could we reset the scopes of entities associated with the new
4889 -- procedure here via a loop over entities rather than doing it in
4890 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4893 end Check_Unnesting_Elaboration_Code;
4895 ---------------------------------------
4896 -- Check_Unnesting_In_Decls_Or_Stmts --
4897 ---------------------------------------
4899 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
4900 Decl_Or_Stmt : Node_Id;
4903 if Unnest_Subprogram_Mode
4904 and then Present (Decls_Or_Stmts)
4906 Decl_Or_Stmt := First (Decls_Or_Stmts);
4907 while Present (Decl_Or_Stmt) loop
4908 if Nkind (Decl_Or_Stmt) = N_Block_Statement
4909 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
4911 Unnest_Block (Decl_Or_Stmt);
4913 -- If-statements may contain subprogram bodies at the outer level
4914 -- of their statement lists, and the subprograms may make up-level
4915 -- references (such as to objects declared in the same statement
4916 -- list). Unlike block and loop cases, however, we don't have an
4917 -- entity on which to test the Contains_Subprogram flag, so
4918 -- Unnest_If_Statement must traverse the statement lists to
4919 -- determine whether there are nested subprograms present.
4921 elsif Nkind (Decl_Or_Stmt) = N_If_Statement then
4922 Unnest_If_Statement (Decl_Or_Stmt);
4924 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
4926 Id : constant Entity_Id :=
4927 Entity (Identifier (Decl_Or_Stmt));
4930 -- When a top-level loop within declarations of a library
4931 -- package spec or body contains nested subprograms, we wrap
4932 -- it in a procedure to handle possible up-level references
4933 -- to entities associated with the loop (such as loop
4936 if Present (Id) and then Contains_Subprogram (Id) then
4937 Unnest_Loop (Decl_Or_Stmt);
4941 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration
4942 and then not Modify_Tree_For_C
4944 Check_Unnesting_In_Decls_Or_Stmts
4945 (Visible_Declarations (Specification (Decl_Or_Stmt)));
4946 Check_Unnesting_In_Decls_Or_Stmts
4947 (Private_Declarations (Specification (Decl_Or_Stmt)));
4949 elsif Nkind (Decl_Or_Stmt) = N_Package_Body
4950 and then not Modify_Tree_For_C
4952 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
4953 if Present (Statements
4954 (Handled_Statement_Sequence (Decl_Or_Stmt)))
4956 Check_Unnesting_In_Decls_Or_Stmts (Statements
4957 (Handled_Statement_Sequence (Decl_Or_Stmt)));
4958 Check_Unnesting_In_Handlers (Decl_Or_Stmt);
4962 Next (Decl_Or_Stmt);
4965 end Check_Unnesting_In_Decls_Or_Stmts;
4967 ---------------------------------
4968 -- Check_Unnesting_In_Handlers --
4969 ---------------------------------
4971 procedure Check_Unnesting_In_Handlers (N : Node_Id) is
4972 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4975 if Present (Stmt_Seq)
4976 and then Present (Exception_Handlers (Stmt_Seq))
4979 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
4981 while Present (Handler) loop
4982 if Present (Statements (Handler)) then
4983 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
4990 end Check_Unnesting_In_Handlers;
4992 ------------------------------
4993 -- Check_Visibly_Controlled --
4994 ------------------------------
4996 procedure Check_Visibly_Controlled
4997 (Prim : Final_Primitives;
4999 E : in out Entity_Id;
5000 Cref : in out Node_Id)
5002 Parent_Type : Entity_Id;
5006 if Is_Derived_Type (Typ)
5007 and then Comes_From_Source (E)
5008 and then not Present (Overridden_Operation (E))
5010 -- We know that the explicit operation on the type does not override
5011 -- the inherited operation of the parent, and that the derivation
5012 -- is from a private type that is not visibly controlled.
5014 Parent_Type := Etype (Typ);
5015 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
5017 if Present (Op) then
5020 -- Wrap the object to be initialized into the proper
5021 -- unchecked conversion, to be compatible with the operation
5024 if Nkind (Cref) = N_Unchecked_Type_Conversion then
5025 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
5027 Cref := Unchecked_Convert_To (Parent_Type, Cref);
5031 end Check_Visibly_Controlled;
5033 --------------------------
5034 -- Contains_Subprogram --
5035 --------------------------
5037 function Contains_Subprogram (Blk : Entity_Id) return Boolean is
5041 E := First_Entity (Blk);
5043 while Present (E) loop
5044 if Is_Subprogram (E) then
5047 elsif Ekind (E) in E_Block | E_Loop
5048 and then Contains_Subprogram (E)
5057 end Contains_Subprogram;
5063 function Convert_View
5066 Ind : Pos := 1) return Node_Id
5068 Fent : Entity_Id := First_Entity (Proc);
5073 for J in 2 .. Ind loop
5077 Ftyp := Etype (Fent);
5079 if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
5080 Atyp := Entity (Subtype_Mark (Arg));
5082 Atyp := Etype (Arg);
5085 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
5086 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
5089 and then Present (Atyp)
5090 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
5091 and then Base_Type (Underlying_Type (Atyp)) =
5092 Base_Type (Underlying_Type (Ftyp))
5094 return Unchecked_Convert_To (Ftyp, Arg);
5096 -- If the argument is already a conversion, as generated by
5097 -- Make_Init_Call, set the target type to the type of the formal
5098 -- directly, to avoid spurious typing problems.
5100 elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion
5101 and then not Is_Class_Wide_Type (Atyp)
5103 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
5104 Set_Etype (Arg, Ftyp);
5107 -- Otherwise, introduce a conversion when the designated object
5108 -- has a type derived from the formal of the controlled routine.
5110 elsif Is_Private_Type (Ftyp)
5111 and then Present (Atyp)
5112 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
5114 return Unchecked_Convert_To (Ftyp, Arg);
5121 -------------------------------
5122 -- CW_Or_Has_Controlled_Part --
5123 -------------------------------
5125 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
5127 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
5128 end CW_Or_Has_Controlled_Part;
5130 ------------------------
5131 -- Enclosing_Function --
5132 ------------------------
5134 function Enclosing_Function (E : Entity_Id) return Entity_Id is
5135 Func_Id : Entity_Id;
5139 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
5140 if Ekind (Func_Id) = E_Function then
5144 Func_Id := Scope (Func_Id);
5148 end Enclosing_Function;
5150 -------------------------------
5151 -- Establish_Transient_Scope --
5152 -------------------------------
5154 -- This procedure is called each time a transient block has to be inserted
5155 -- that is to say for each call to a function with unconstrained or tagged
5156 -- result. It creates a new scope on the scope stack in order to enclose
5157 -- all transient variables generated.
5159 procedure Establish_Transient_Scope
5161 Manage_Sec_Stack : Boolean)
5163 procedure Create_Transient_Scope (Constr : Node_Id);
5164 -- Place a new scope on the scope stack in order to service construct
5165 -- Constr. The new scope may also manage the secondary stack.
5167 procedure Delegate_Sec_Stack_Management;
5168 -- Move the management of the secondary stack to the nearest enclosing
5171 function Find_Enclosing_Transient_Scope return Entity_Id;
5172 -- Examine the scope stack looking for the nearest enclosing transient
5173 -- scope. Return Empty if no such scope exists.
5175 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
5176 -- Determine whether arbitrary Id denotes a package or subprogram [body]
5178 ----------------------------
5179 -- Create_Transient_Scope --
5180 ----------------------------
5182 procedure Create_Transient_Scope (Constr : Node_Id) is
5183 Loc : constant Source_Ptr := Sloc (N);
5185 Iter_Loop : Entity_Id;
5186 Trans_Scop : Entity_Id;
5189 Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
5190 Set_Etype (Trans_Scop, Standard_Void_Type);
5192 Push_Scope (Trans_Scop);
5193 Set_Node_To_Be_Wrapped (Constr);
5194 Set_Scope_Is_Transient;
5196 -- The transient scope must also manage the secondary stack
5198 if Manage_Sec_Stack then
5199 Set_Uses_Sec_Stack (Trans_Scop);
5200 Check_Restriction (No_Secondary_Stack, N);
5202 -- The expansion of iterator loops generates references to objects
5203 -- in order to extract elements from a container:
5205 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
5206 -- Obj : <object type> renames Ref.all.Element.all;
5208 -- These references are controlled and returned on the secondary
5209 -- stack. A new reference is created at each iteration of the loop
5210 -- and as a result it must be finalized and the space occupied by
5211 -- it on the secondary stack reclaimed at the end of the current
5214 -- When the context that requires a transient scope is a call to
5215 -- routine Reference, the node to be wrapped is the source object:
5217 -- for Obj of Container loop
5219 -- Routine Wrap_Transient_Declaration however does not generate
5220 -- a physical block as wrapping a declaration will kill it too
5221 -- early. To handle this peculiar case, mark the related iterator
5222 -- loop as requiring the secondary stack. This signals the
5223 -- finalization machinery to manage the secondary stack (see
5224 -- routine Process_Statements_For_Controlled_Objects).
5226 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
5228 if Present (Iter_Loop) then
5229 Set_Uses_Sec_Stack (Iter_Loop);
5233 if Debug_Flag_W then
5234 Write_Str (" <Transient>");
5237 end Create_Transient_Scope;
5239 -----------------------------------
5240 -- Delegate_Sec_Stack_Management --
5241 -----------------------------------
5243 procedure Delegate_Sec_Stack_Management is
5244 Scop_Id : Entity_Id;
5245 Scop_Rec : Scope_Stack_Entry;
5248 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
5249 Scop_Rec := Scope_Stack.Table (Index);
5250 Scop_Id := Scop_Rec.Entity;
5252 -- Prevent the search from going too far or within the scope space
5255 if Scop_Id = Standard_Standard then
5258 -- No transient scope should be encountered during the traversal
5259 -- because Establish_Transient_Scope should have already handled
5262 elsif Scop_Rec.Is_Transient then
5263 pragma Assert (False);
5266 -- The construct which requires secondary stack management is
5267 -- always enclosed by a package or subprogram scope.
5269 elsif Is_Package_Or_Subprogram (Scop_Id) then
5270 Set_Uses_Sec_Stack (Scop_Id);
5271 Check_Restriction (No_Secondary_Stack, N);
5277 -- At this point no suitable scope was found. This should never occur
5278 -- because a construct is always enclosed by a compilation unit which
5281 pragma Assert (False);
5282 end Delegate_Sec_Stack_Management;
5284 ------------------------------------
5285 -- Find_Enclosing_Transient_Scope --
5286 ------------------------------------
5288 function Find_Enclosing_Transient_Scope return Entity_Id is
5289 Scop_Id : Entity_Id;
5290 Scop_Rec : Scope_Stack_Entry;
5293 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
5294 Scop_Rec := Scope_Stack.Table (Index);
5295 Scop_Id := Scop_Rec.Entity;
5297 -- Prevent the search from going too far or within the scope space
5300 if Scop_Id = Standard_Standard
5301 or else Is_Package_Or_Subprogram (Scop_Id)
5305 elsif Scop_Rec.Is_Transient then
5311 end Find_Enclosing_Transient_Scope;
5313 ------------------------------
5314 -- Is_Package_Or_Subprogram --
5315 ------------------------------
5317 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
5319 return Ekind (Id) in E_Entry
5324 | E_Subprogram_Body;
5325 end Is_Package_Or_Subprogram;
5329 Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
5332 -- Start of processing for Establish_Transient_Scope
5335 -- Do not create a new transient scope if there is an existing transient
5336 -- scope on the stack.
5338 if Present (Trans_Id) then
5340 -- If the transient scope was requested for purposes of managing the
5341 -- secondary stack, then the existing scope must perform this task.
5343 if Manage_Sec_Stack then
5344 Set_Uses_Sec_Stack (Trans_Id);
5350 -- At this point it is known that the scope stack is free of transient
5351 -- scopes. Locate the proper construct which must be serviced by a new
5354 Context := Find_Transient_Context (N);
5356 if Present (Context) then
5357 if Nkind (Context) = N_Assignment_Statement then
5359 -- An assignment statement with suppressed controlled semantics
5360 -- does not need a transient scope because finalization is not
5361 -- desirable at this point. Note that No_Ctrl_Actions is also
5362 -- set for non-controlled assignments to suppress dispatching
5365 if No_Ctrl_Actions (Context)
5366 and then Needs_Finalization (Etype (Name (Context)))
5368 -- When a controlled component is initialized by a function
5369 -- call, the result on the secondary stack is always assigned
5370 -- to the component. Signal the nearest suitable scope that it
5371 -- is safe to manage the secondary stack.
5373 if Manage_Sec_Stack and then Within_Init_Proc then
5374 Delegate_Sec_Stack_Management;
5377 -- Otherwise the assignment is a normal transient context and thus
5378 -- requires a transient scope.
5381 Create_Transient_Scope (Context);
5387 Create_Transient_Scope (Context);
5390 end Establish_Transient_Scope;
5392 ----------------------------
5393 -- Expand_Cleanup_Actions --
5394 ----------------------------
5396 procedure Expand_Cleanup_Actions (N : Node_Id) is
5398 (Nkind (N) in N_Block_Statement
5400 | N_Extended_Return_Statement
5404 Scop : constant Entity_Id := Current_Scope;
5406 Is_Asynchronous_Call : constant Boolean :=
5407 Nkind (N) = N_Block_Statement
5408 and then Is_Asynchronous_Call_Block (N);
5409 Is_Master : constant Boolean :=
5410 Nkind (N) /= N_Extended_Return_Statement
5411 and then Nkind (N) /= N_Entry_Body
5412 and then Is_Task_Master (N);
5413 Is_Protected_Subp_Body : constant Boolean :=
5414 Nkind (N) = N_Subprogram_Body
5415 and then Is_Protected_Subprogram_Body (N);
5416 Is_Task_Allocation : constant Boolean :=
5417 Nkind (N) = N_Block_Statement
5418 and then Is_Task_Allocation_Block (N);
5419 Is_Task_Body : constant Boolean :=
5420 Nkind (Original_Node (N)) = N_Task_Body;
5422 -- We mark the secondary stack if it is used in this construct, and
5423 -- we're not returning a function result on the secondary stack, except
5424 -- that a build-in-place function that might or might not return on the
5425 -- secondary stack always needs a mark. A run-time test is required in
5426 -- the case where the build-in-place function has a BIP_Alloc extra
5427 -- parameter (see Create_Finalizer).
5429 Needs_Sec_Stack_Mark : constant Boolean :=
5430 (Uses_Sec_Stack (Scop)
5432 not Sec_Stack_Needed_For_Return (Scop))
5434 (Is_Build_In_Place_Function (Scop)
5435 and then Needs_BIP_Alloc_Form (Scop));
5437 Needs_Custom_Cleanup : constant Boolean :=
5438 Nkind (N) = N_Block_Statement
5439 and then Present (Cleanup_Actions (N));
5441 Has_Postcondition : constant Boolean :=
5442 Nkind (N) = N_Subprogram_Body
5444 (Postconditions_Proc
5445 (Unique_Defining_Entity (N)));
5447 Actions_Required : constant Boolean :=
5448 Requires_Cleanup_Actions (N, True)
5449 or else Is_Asynchronous_Call
5451 or else Is_Protected_Subp_Body
5452 or else Is_Task_Allocation
5453 or else Is_Task_Body
5454 or else Needs_Sec_Stack_Mark
5455 or else Needs_Custom_Cleanup;
5457 HSS : Node_Id := Handled_Statement_Sequence (N);
5461 procedure Wrap_HSS_In_Block;
5462 -- Move HSS inside a new block along with the original exception
5463 -- handlers. Make the newly generated block the sole statement of HSS.
5465 -----------------------
5466 -- Wrap_HSS_In_Block --
5467 -----------------------
5469 procedure Wrap_HSS_In_Block is
5471 Block_Id : Entity_Id;
5475 -- Preserve end label to provide proper cross-reference information
5477 End_Lab := End_Label (HSS);
5479 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
5481 Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
5482 Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
5483 Set_Etype (Block_Id, Standard_Void_Type);
5484 Set_Block_Node (Block_Id, Identifier (Block));
5486 -- Signal the finalization machinery that this particular block
5487 -- contains the original context.
5489 Set_Is_Finalization_Wrapper (Block);
5491 Set_Handled_Statement_Sequence (N,
5492 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
5493 HSS := Handled_Statement_Sequence (N);
5495 Set_First_Real_Statement (HSS, Block);
5496 Set_End_Label (HSS, End_Lab);
5498 -- Comment needed here, see RH for 1.306 ???
5500 if Nkind (N) = N_Subprogram_Body then
5501 Set_Has_Nested_Block_With_Handler (Scop);
5503 end Wrap_HSS_In_Block;
5505 -- Start of processing for Expand_Cleanup_Actions
5508 -- The current construct does not need any form of servicing
5510 if not Actions_Required then
5513 -- If the current node is a rewritten task body and the descriptors have
5514 -- not been delayed (due to some nested instantiations), do not generate
5515 -- redundant cleanup actions.
5518 and then Nkind (N) = N_Subprogram_Body
5519 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
5524 -- If an extended return statement contains something like
5528 -- where F is a build-in-place function call returning a controlled
5529 -- type, then a temporary object will be implicitly declared as part
5530 -- of the statement list, and this will need cleanup. In such cases,
5533 -- return Result : T := ... do
5534 -- <statements> -- possibly with handlers
5539 -- return Result : T := ... do
5540 -- declare -- no declarations
5542 -- <statements> -- possibly with handlers
5543 -- end; -- no handlers
5546 -- So Expand_Cleanup_Actions will end up being called recursively on the
5549 if Nkind (N) = N_Extended_Return_Statement then
5551 Block : constant Node_Id :=
5552 Make_Block_Statement (Sloc (N),
5553 Declarations => Empty_List,
5554 Handled_Statement_Sequence =>
5555 Handled_Statement_Sequence (N));
5557 Set_Handled_Statement_Sequence (N,
5558 Make_Handled_Sequence_Of_Statements (Sloc (N),
5559 Statements => New_List (Block)));
5564 -- Analysis of the block did all the work
5569 if Needs_Custom_Cleanup then
5570 Cln := Cleanup_Actions (N);
5576 Decls : List_Id := Declarations (N);
5578 Mark : Entity_Id := Empty;
5579 New_Decls : List_Id;
5582 -- If we are generating expanded code for debugging purposes, use the
5583 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5584 -- be updated subsequently to reference the proper line in .dg files.
5585 -- If we are not debugging generated code, use No_Location instead,
5586 -- so that no debug information is generated for the cleanup code.
5587 -- This makes the behavior of the NEXT command in GDB monotonic, and
5588 -- makes the placement of breakpoints more accurate.
5590 if Debug_Generated_Code then
5596 -- A task activation call has already been built for a task
5597 -- allocation block.
5599 if not Is_Task_Allocation then
5600 Build_Task_Activation_Call (N);
5604 Establish_Task_Master (N);
5607 New_Decls := New_List;
5609 -- If secondary stack is in use, generate:
5611 -- Mnn : constant Mark_Id := SS_Mark;
5613 if Needs_Sec_Stack_Mark then
5614 Mark := Make_Temporary (Loc, 'M');
5616 Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
5617 Set_Uses_Sec_Stack (Scop, False);
5620 -- If exception handlers are present, wrap the sequence of statements
5621 -- in a block since it is not possible to have exception handlers and
5622 -- an At_End handler in the same construct.
5624 if Present (Exception_Handlers (HSS)) then
5627 -- Ensure that the First_Real_Statement field is set
5629 elsif No (First_Real_Statement (HSS)) then
5630 Set_First_Real_Statement (HSS, First (Statements (HSS)));
5633 -- Do not move the Activation_Chain declaration in the context of
5634 -- task allocation blocks. Task allocation blocks use _chain in their
5635 -- cleanup handlers and gigi complains if it is declared in the
5636 -- sequence of statements of the scope that declares the handler.
5638 if Is_Task_Allocation then
5640 Chain : constant Entity_Id := Activation_Chain_Entity (N);
5644 Decl := First (Decls);
5645 while Nkind (Decl) /= N_Object_Declaration
5646 or else Defining_Identifier (Decl) /= Chain
5650 -- A task allocation block should always include a _chain
5653 pragma Assert (Present (Decl));
5657 Prepend_To (New_Decls, Decl);
5661 -- Move the _postconditions subprogram declaration and its associated
5662 -- objects into the declarations section so that it is callable
5663 -- within _postconditions.
5665 if Has_Postcondition then
5668 Prev_Decl : Node_Id;
5672 Prev (Subprogram_Body
5673 (Postconditions_Proc (Current_Subprogram)));
5674 while Present (Decl) loop
5675 Prev_Decl := Prev (Decl);
5678 Prepend_To (New_Decls, Decl);
5680 exit when Nkind (Decl) = N_Subprogram_Declaration
5681 and then Chars (Corresponding_Body (Decl))
5682 = Name_uPostconditions;
5689 -- Ensure the presence of a declaration list in order to successfully
5690 -- append all original statements to it.
5693 Set_Declarations (N, New_List);
5694 Decls := Declarations (N);
5697 -- Move the declarations into the sequence of statements in order to
5698 -- have them protected by the At_End handler. It may seem weird to
5699 -- put declarations in the sequence of statement but in fact nothing
5700 -- forbids that at the tree level.
5702 Append_List_To (Decls, Statements (HSS));
5703 Set_Statements (HSS, Decls);
5705 -- Reset the Sloc of the handled statement sequence to properly
5706 -- reflect the new initial "statement" in the sequence.
5708 Set_Sloc (HSS, Sloc (First (Decls)));
5710 -- The declarations of finalizer spec and auxiliary variables replace
5711 -- the old declarations that have been moved inward.
5713 Set_Declarations (N, New_Decls);
5714 Analyze_Declarations (New_Decls);
5716 -- Generate finalization calls for all controlled objects appearing
5717 -- in the statements of N. Add context specific cleanup for various
5722 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
5724 Top_Decls => New_Decls,
5725 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
5729 if Present (Fin_Id) then
5730 Build_Finalizer_Call (N, Fin_Id);
5733 end Expand_Cleanup_Actions;
5735 ---------------------------
5736 -- Expand_N_Package_Body --
5737 ---------------------------
5739 -- Add call to Activate_Tasks if body is an activator (actual processing
5740 -- is in chapter 9).
5742 -- Generate subprogram descriptor for elaboration routine
5744 -- Encode entity names in package body
5746 procedure Expand_N_Package_Body (N : Node_Id) is
5747 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
5751 -- This is done only for non-generic packages
5753 if Ekind (Spec_Id) = E_Package then
5754 Push_Scope (Spec_Id);
5756 -- Build dispatch tables of library level tagged types
5758 if Tagged_Type_Expansion
5759 and then Is_Library_Level_Entity (Spec_Id)
5761 Build_Static_Dispatch_Tables (N);
5764 -- If procedures marked with CUDA_Global have been defined within N,
5765 -- we need to register them with the CUDA runtime at program startup.
5766 -- This requires multiple declarations and function calls which need
5767 -- to be appended to N's declarations.
5769 Build_And_Insert_CUDA_Initialization (N);
5771 Build_Task_Activation_Call (N);
5773 -- Verify the run-time semantics of pragma Initial_Condition at the
5774 -- end of the body statements.
5776 Expand_Pragma_Initial_Condition (Spec_Id, N);
5778 -- If this is a library-level package and unnesting is enabled,
5779 -- check for the presence of blocks with nested subprograms occurring
5780 -- in elaboration code, and generate procedures to encapsulate the
5781 -- blocks in case the nested subprograms make up-level references.
5783 if Unnest_Subprogram_Mode
5785 Is_Library_Level_Entity (Current_Scope)
5787 Check_Unnesting_Elaboration_Code (N);
5788 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
5789 Check_Unnesting_In_Handlers (N);
5795 Set_Elaboration_Flag (N, Spec_Id);
5796 Set_In_Package_Body (Spec_Id, False);
5798 -- Set to encode entity names in package body before gigi is called
5800 Qualify_Entity_Names (N);
5802 if Ekind (Spec_Id) /= E_Generic_Package then
5805 Clean_Stmts => No_List,
5807 Top_Decls => No_List,
5808 Defer_Abort => False,
5811 if Present (Fin_Id) then
5813 Body_Ent : Node_Id := Defining_Unit_Name (N);
5816 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
5817 Body_Ent := Defining_Identifier (Body_Ent);
5820 Set_Finalizer (Body_Ent, Fin_Id);
5824 end Expand_N_Package_Body;
5826 ----------------------------------
5827 -- Expand_N_Package_Declaration --
5828 ----------------------------------
5830 -- Add call to Activate_Tasks if there are tasks declared and the package
5831 -- has no body. Note that in Ada 83 this may result in premature activation
5832 -- of some tasks, given that we cannot tell whether a body will eventually
5835 procedure Expand_N_Package_Declaration (N : Node_Id) is
5836 Id : constant Entity_Id := Defining_Entity (N);
5837 Spec : constant Node_Id := Specification (N);
5841 No_Body : Boolean := False;
5842 -- True in the case of a package declaration that is a compilation
5843 -- unit and for which no associated body will be compiled in this
5847 -- Case of a package declaration other than a compilation unit
5849 if Nkind (Parent (N)) /= N_Compilation_Unit then
5852 -- Case of a compilation unit that does not require a body
5854 elsif not Body_Required (Parent (N))
5855 and then not Unit_Requires_Body (Id)
5859 -- Special case of generating calling stubs for a remote call interface
5860 -- package: even though the package declaration requires one, the body
5861 -- won't be processed in this compilation (so any stubs for RACWs
5862 -- declared in the package must be generated here, along with the spec).
5864 elsif Parent (N) = Cunit (Main_Unit)
5865 and then Is_Remote_Call_Interface (Id)
5866 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
5871 -- For a nested instance, delay processing until freeze point
5873 if Has_Delayed_Freeze (Id)
5874 and then Nkind (Parent (N)) /= N_Compilation_Unit
5879 -- For a package declaration that implies no associated body, generate
5880 -- task activation call and RACW supporting bodies now (since we won't
5881 -- have a specific separate compilation unit for that).
5886 -- Generate RACW subprogram bodies
5888 if Has_RACW (Id) then
5889 Decls := Private_Declarations (Spec);
5892 Decls := Visible_Declarations (Spec);
5897 Set_Visible_Declarations (Spec, Decls);
5900 Append_RACW_Bodies (Decls, Id);
5901 Analyze_List (Decls);
5904 -- Generate task activation call as last step of elaboration
5906 if Present (Activation_Chain_Entity (N)) then
5907 Build_Task_Activation_Call (N);
5910 -- Verify the run-time semantics of pragma Initial_Condition at the
5911 -- end of the private declarations when the package lacks a body.
5913 Expand_Pragma_Initial_Condition (Id, N);
5918 -- Build dispatch tables of library level tagged types
5920 if Tagged_Type_Expansion
5921 and then (Is_Compilation_Unit (Id)
5922 or else (Is_Generic_Instance (Id)
5923 and then Is_Library_Level_Entity (Id)))
5925 Build_Static_Dispatch_Tables (N);
5928 -- Note: it is not necessary to worry about generating a subprogram
5929 -- descriptor, since the only way to get exception handlers into a
5930 -- package spec is to include instantiations, and that would cause
5931 -- generation of subprogram descriptors to be delayed in any case.
5933 -- Set to encode entity names in package spec before gigi is called
5935 Qualify_Entity_Names (N);
5937 if Ekind (Id) /= E_Generic_Package then
5940 Clean_Stmts => No_List,
5942 Top_Decls => No_List,
5943 Defer_Abort => False,
5946 Set_Finalizer (Id, Fin_Id);
5949 -- If this is a library-level package and unnesting is enabled,
5950 -- check for the presence of blocks with nested subprograms occurring
5951 -- in elaboration code, and generate procedures to encapsulate the
5952 -- blocks in case the nested subprograms make up-level references.
5954 if Unnest_Subprogram_Mode
5955 and then Is_Library_Level_Entity (Current_Scope)
5957 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
5958 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
5960 end Expand_N_Package_Declaration;
5962 ----------------------------
5963 -- Find_Transient_Context --
5964 ----------------------------
5966 function Find_Transient_Context (N : Node_Id) return Node_Id is
5973 while Present (Curr) loop
5974 case Nkind (Curr) is
5978 -- Declarations act as a boundary for a transient scope even if
5979 -- they are not wrapped, see Wrap_Transient_Declaration.
5981 when N_Object_Declaration
5982 | N_Object_Renaming_Declaration
5983 | N_Subtype_Declaration
5989 -- Statements and statement-like constructs act as a boundary for
5990 -- a transient scope.
5992 when N_Accept_Alternative
5993 | N_Attribute_Definition_Clause
5995 | N_Case_Statement_Alternative
5997 | N_Delay_Alternative
5998 | N_Delay_Until_Statement
5999 | N_Delay_Relative_Statement
6000 | N_Discriminant_Association
6002 | N_Entry_Body_Formal_Part
6005 | N_Iteration_Scheme
6006 | N_Terminate_Alternative
6008 pragma Assert (Present (Prev));
6011 when N_Assignment_Statement =>
6014 when N_Entry_Call_Statement
6015 | N_Procedure_Call_Statement
6017 -- When an entry or procedure call acts as the alternative of a
6018 -- conditional or timed entry call, the proper context is that
6019 -- of the alternative.
6021 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
6022 and then Nkind (Parent (Parent (Curr))) in
6023 N_Conditional_Entry_Call | N_Timed_Entry_Call
6025 return Parent (Parent (Curr));
6027 -- General case for entry or procedure calls
6035 -- Pragma Check is not a valid transient context in GNATprove
6036 -- mode because the pragma must remain unchanged.
6039 and then Get_Pragma_Id (Curr) = Pragma_Check
6043 -- General case for pragmas
6049 when N_Raise_Statement =>
6052 when N_Simple_Return_Statement =>
6054 -- A return statement is not a valid transient context when the
6055 -- function itself requires transient scope management because
6056 -- the result will be reclaimed too early.
6058 if Requires_Transient_Scope (Etype
6059 (Return_Applies_To (Return_Statement_Entity (Curr))))
6063 -- General case for return statements
6071 when N_Attribute_Reference =>
6072 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
6076 -- An Ada 2012 iterator specification is not a valid context
6077 -- because Analyze_Iterator_Specification already employs special
6078 -- processing for it.
6080 when N_Iterator_Specification =>
6083 when N_Loop_Parameter_Specification =>
6085 -- An iteration scheme is not a valid context because routine
6086 -- Analyze_Iteration_Scheme already employs special processing.
6088 if Nkind (Parent (Curr)) = N_Iteration_Scheme then
6091 return Parent (Curr);
6096 -- The following nodes represent "dummy contexts" which do not
6097 -- need to be wrapped.
6099 when N_Component_Declaration
6100 | N_Discriminant_Specification
6101 | N_Parameter_Specification
6105 -- If the traversal leaves a scope without having been able to
6106 -- find a construct to wrap, something is going wrong, but this
6107 -- can happen in error situations that are not detected yet (such
6108 -- as a dynamic string in a pragma Export).
6110 when N_Block_Statement
6113 | N_Package_Declaration
6127 Curr := Parent (Curr);
6131 end Find_Transient_Context;
6133 ----------------------------------
6134 -- Has_New_Controlled_Component --
6135 ----------------------------------
6137 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
6141 if not Is_Tagged_Type (E) then
6142 return Has_Controlled_Component (E);
6143 elsif not Is_Derived_Type (E) then
6144 return Has_Controlled_Component (E);
6147 Comp := First_Component (E);
6148 while Present (Comp) loop
6149 if Chars (Comp) = Name_uParent then
6152 elsif Scope (Original_Record_Component (Comp)) = E
6153 and then Needs_Finalization (Etype (Comp))
6158 Next_Component (Comp);
6162 end Has_New_Controlled_Component;
6164 ---------------------------------
6165 -- Has_Simple_Protected_Object --
6166 ---------------------------------
6168 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
6170 if Has_Task (T) then
6173 elsif Is_Simple_Protected_Type (T) then
6176 elsif Is_Array_Type (T) then
6177 return Has_Simple_Protected_Object (Component_Type (T));
6179 elsif Is_Record_Type (T) then
6184 Comp := First_Component (T);
6185 while Present (Comp) loop
6186 if Has_Simple_Protected_Object (Etype (Comp)) then
6190 Next_Component (Comp);
6199 end Has_Simple_Protected_Object;
6201 ------------------------------------
6202 -- Insert_Actions_In_Scope_Around --
6203 ------------------------------------
6205 procedure Insert_Actions_In_Scope_Around
6208 Manage_SS : Boolean)
6210 Act_Before : constant List_Id :=
6211 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
6212 Act_After : constant List_Id :=
6213 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
6214 Act_Cleanup : constant List_Id :=
6215 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
6216 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
6217 -- Last), but this was incorrect as Process_Transients_In_Scope may
6218 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
6220 procedure Process_Transients_In_Scope
6221 (First_Object : Node_Id;
6222 Last_Object : Node_Id;
6223 Related_Node : Node_Id);
6224 -- Find all transient objects in the list First_Object .. Last_Object
6225 -- and generate finalization actions for them. Related_Node denotes the
6226 -- node which created all transient objects.
6228 ---------------------------------
6229 -- Process_Transients_In_Scope --
6230 ---------------------------------
6232 procedure Process_Transients_In_Scope
6233 (First_Object : Node_Id;
6234 Last_Object : Node_Id;
6235 Related_Node : Node_Id)
6237 Must_Hook : Boolean := False;
6238 -- Flag denoting whether the context requires transient object
6239 -- export to the outer finalizer.
6241 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
6242 -- Determine whether an arbitrary node denotes a subprogram call
6244 procedure Detect_Subprogram_Call is
6245 new Traverse_Proc (Is_Subprogram_Call);
6247 procedure Process_Transient_In_Scope
6248 (Obj_Decl : Node_Id;
6249 Blk_Data : Finalization_Exception_Data;
6250 Blk_Stmts : List_Id);
6251 -- Generate finalization actions for a single transient object
6252 -- denoted by object declaration Obj_Decl. Blk_Data is the
6253 -- exception data of the enclosing block. Blk_Stmts denotes the
6254 -- statements of the enclosing block.
6256 ------------------------
6257 -- Is_Subprogram_Call --
6258 ------------------------
6260 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
6262 -- A regular procedure or function call
6264 if Nkind (N) in N_Subprogram_Call then
6270 -- Heavy expansion may relocate function calls outside the related
6271 -- node. Inspect the original node to detect the initial placement
6274 elsif Is_Rewrite_Substitution (N) then
6275 Detect_Subprogram_Call (Original_Node (N));
6283 -- Generalized indexing always involves a function call
6285 elsif Nkind (N) = N_Indexed_Component
6286 and then Present (Generalized_Indexing (N))
6296 end Is_Subprogram_Call;
6298 --------------------------------
6299 -- Process_Transient_In_Scope --
6300 --------------------------------
6302 procedure Process_Transient_In_Scope
6303 (Obj_Decl : Node_Id;
6304 Blk_Data : Finalization_Exception_Data;
6305 Blk_Stmts : List_Id)
6307 Loc : constant Source_Ptr := Sloc (Obj_Decl);
6308 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
6310 Fin_Stmts : List_Id;
6311 Hook_Assign : Node_Id;
6312 Hook_Clear : Node_Id;
6313 Hook_Decl : Node_Id;
6314 Hook_Insert : Node_Id;
6318 -- Mark the transient object as successfully processed to avoid
6319 -- double finalization.
6321 Set_Is_Finalized_Transient (Obj_Id);
6323 -- Construct all the pieces necessary to hook and finalize the
6324 -- transient object.
6326 Build_Transient_Object_Statements
6327 (Obj_Decl => Obj_Decl,
6328 Fin_Call => Fin_Call,
6329 Hook_Assign => Hook_Assign,
6330 Hook_Clear => Hook_Clear,
6331 Hook_Decl => Hook_Decl,
6332 Ptr_Decl => Ptr_Decl);
6334 -- The context contains at least one subprogram call which may
6335 -- raise an exception. This scenario employs "hooking" to pass
6336 -- transient objects to the enclosing finalizer in case of an
6341 -- Add the access type which provides a reference to the
6342 -- transient object. Generate:
6344 -- type Ptr_Typ is access all Desig_Typ;
6346 Insert_Action (Obj_Decl, Ptr_Decl);
6348 -- Add the temporary which acts as a hook to the transient
6349 -- object. Generate:
6351 -- Hook : Ptr_Typ := null;
6353 Insert_Action (Obj_Decl, Hook_Decl);
6355 -- When the transient object is initialized by an aggregate,
6356 -- the hook must capture the object after the last aggregate
6357 -- assignment takes place. Only then is the object considered
6358 -- fully initialized. Generate:
6360 -- Hook := Ptr_Typ (Obj_Id);
6362 -- Hook := Obj_Id'Unrestricted_Access;
6364 -- Similarly if we have a build in place call: we must
6365 -- initialize Hook only after the call has happened, otherwise
6366 -- Obj_Id will not be initialized yet.
6368 if Ekind (Obj_Id) in E_Constant | E_Variable then
6369 if Present (Last_Aggregate_Assignment (Obj_Id)) then
6370 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
6371 elsif Present (BIP_Initialization_Call (Obj_Id)) then
6372 Hook_Insert := BIP_Initialization_Call (Obj_Id);
6374 Hook_Insert := Obj_Decl;
6377 -- Otherwise the hook seizes the related object immediately
6380 Hook_Insert := Obj_Decl;
6383 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
6386 -- When exception propagation is enabled wrap the hook clear
6387 -- statement and the finalization call into a block to catch
6388 -- potential exceptions raised during finalization. Generate:
6392 -- [Deep_]Finalize (Obj_Ref);
6396 -- if not Raised then
6399 -- (Enn, Get_Current_Excep.all.all);
6403 if Exceptions_OK then
6404 Fin_Stmts := New_List;
6407 Append_To (Fin_Stmts, Hook_Clear);
6410 Append_To (Fin_Stmts, Fin_Call);
6412 Prepend_To (Blk_Stmts,
6413 Make_Block_Statement (Loc,
6414 Handled_Statement_Sequence =>
6415 Make_Handled_Sequence_Of_Statements (Loc,
6416 Statements => Fin_Stmts,
6417 Exception_Handlers => New_List (
6418 Build_Exception_Handler (Blk_Data)))));
6420 -- Otherwise generate:
6423 -- [Deep_]Finalize (Obj_Ref);
6425 -- Note that the statements are inserted in reverse order to
6426 -- achieve the desired final order outlined above.
6429 Prepend_To (Blk_Stmts, Fin_Call);
6432 Prepend_To (Blk_Stmts, Hook_Clear);
6435 end Process_Transient_In_Scope;
6439 Built : Boolean := False;
6440 Blk_Data : Finalization_Exception_Data;
6441 Blk_Decl : Node_Id := Empty;
6442 Blk_Decls : List_Id := No_List;
6444 Blk_Stmts : List_Id := No_List;
6445 Loc : Source_Ptr := No_Location;
6448 -- Start of processing for Process_Transients_In_Scope
6451 -- The expansion performed by this routine is as follows:
6453 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
6454 -- Hook_1 : Ptr_Typ_1 := null;
6455 -- Ctrl_Trans_Obj_1 : ...;
6456 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
6458 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
6459 -- Hook_N : Ptr_Typ_N := null;
6460 -- Ctrl_Trans_Obj_N : ...;
6461 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
6464 -- Abrt : constant Boolean := ...;
6465 -- Ex : Exception_Occurrence;
6466 -- Raised : Boolean := False;
6473 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
6477 -- if not Raised then
6479 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6484 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
6488 -- if not Raised then
6490 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6495 -- if Raised and not Abrt then
6496 -- Raise_From_Controlled_Operation (Ex);
6500 -- Recognize a scenario where the transient context is an object
6501 -- declaration initialized by a build-in-place function call:
6503 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
6505 -- The rough expansion of the above is:
6507 -- Temp : ... := Ctrl_Func_Call;
6509 -- Res : ... := BIP_Func_Call (..., Obj, ...);
6511 -- The finalization of any transient object must happen after the
6512 -- build-in-place function call is executed.
6514 if Nkind (N) = N_Object_Declaration
6515 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
6518 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
6520 -- Search the context for at least one subprogram call. If found, the
6521 -- machinery exports all transient objects to the enclosing finalizer
6522 -- due to the possibility of abnormal call termination.
6525 Detect_Subprogram_Call (N);
6526 Blk_Ins := Last_Object;
6530 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
6533 -- Examine all objects in the list First_Object .. Last_Object
6535 Obj_Decl := First_Object;
6536 while Present (Obj_Decl) loop
6537 if Nkind (Obj_Decl) = N_Object_Declaration
6538 and then Analyzed (Obj_Decl)
6539 and then Is_Finalizable_Transient (Obj_Decl, N)
6541 -- Do not process the node to be wrapped since it will be
6542 -- handled by the enclosing finalizer.
6544 and then Obj_Decl /= Related_Node
6546 Loc := Sloc (Obj_Decl);
6548 -- Before generating the cleanup code for the first transient
6549 -- object, create a wrapper block which houses all hook clear
6550 -- statements and finalization calls. This wrapper is needed by
6555 Blk_Stmts := New_List;
6558 -- Abrt : constant Boolean := ...;
6559 -- Ex : Exception_Occurrence;
6560 -- Raised : Boolean := False;
6562 if Exceptions_OK then
6563 Blk_Decls := New_List;
6564 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
6568 Make_Block_Statement (Loc,
6569 Declarations => Blk_Decls,
6570 Handled_Statement_Sequence =>
6571 Make_Handled_Sequence_Of_Statements (Loc,
6572 Statements => Blk_Stmts));
6575 -- Construct all necessary circuitry to hook and finalize a
6576 -- single transient object.
6578 pragma Assert (Present (Blk_Stmts));
6579 Process_Transient_In_Scope
6580 (Obj_Decl => Obj_Decl,
6581 Blk_Data => Blk_Data,
6582 Blk_Stmts => Blk_Stmts);
6585 -- Terminate the scan after the last object has been processed to
6586 -- avoid touching unrelated code.
6588 if Obj_Decl = Last_Object then
6595 -- Complete the decoration of the enclosing finalization block and
6596 -- insert it into the tree.
6598 if Present (Blk_Decl) then
6600 pragma Assert (Present (Blk_Stmts));
6601 pragma Assert (Loc /= No_Location);
6603 -- Note that this Abort_Undefer does not require a extra block or
6604 -- an AT_END handler because each finalization exception is caught
6605 -- in its own corresponding finalization block. As a result, the
6606 -- call to Abort_Defer always takes place.
6608 if Abort_Allowed then
6609 Prepend_To (Blk_Stmts,
6610 Build_Runtime_Call (Loc, RE_Abort_Defer));
6612 Append_To (Blk_Stmts,
6613 Build_Runtime_Call (Loc, RE_Abort_Undefer));
6617 -- if Raised and then not Abrt then
6618 -- Raise_From_Controlled_Operation (Ex);
6621 if Exceptions_OK then
6622 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
6625 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
6627 end Process_Transients_In_Scope;
6631 Loc : constant Source_Ptr := Sloc (N);
6632 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
6633 First_Obj : Node_Id;
6635 Mark_Id : Entity_Id;
6638 -- Start of processing for Insert_Actions_In_Scope_Around
6641 -- Nothing to do if the scope does not manage the secondary stack or
6642 -- does not contain meaningful actions for insertion.
6645 and then No (Act_Before)
6646 and then No (Act_After)
6647 and then No (Act_Cleanup)
6652 -- If the node to be wrapped is the trigger of an asynchronous select,
6653 -- it is not part of a statement list. The actions must be inserted
6654 -- before the select itself, which is part of some list of statements.
6655 -- Note that the triggering alternative includes the triggering
6656 -- statement and an optional statement list. If the node to be
6657 -- wrapped is part of that list, the normal insertion applies.
6659 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
6660 and then not Is_List_Member (Node_To_Wrap)
6662 Target := Parent (Parent (Node_To_Wrap));
6667 First_Obj := Target;
6670 -- Add all actions associated with a transient scope into the main tree.
6671 -- There are several scenarios here:
6673 -- +--- Before ----+ +----- After ---+
6674 -- 1) First_Obj ....... Target ........ Last_Obj
6676 -- 2) First_Obj ....... Target
6678 -- 3) Target ........ Last_Obj
6680 -- Flag declarations are inserted before the first object
6682 if Present (Act_Before) then
6683 First_Obj := First (Act_Before);
6684 Insert_List_Before (Target, Act_Before);
6687 -- Finalization calls are inserted after the last object
6689 if Present (Act_After) then
6690 Last_Obj := Last (Act_After);
6691 Insert_List_After (Target, Act_After);
6694 -- Mark and release the secondary stack when the context warrants it
6697 Mark_Id := Make_Temporary (Loc, 'M');
6700 -- Mnn : constant Mark_Id := SS_Mark;
6702 Insert_Before_And_Analyze
6703 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
6706 -- SS_Release (Mnn);
6708 Insert_After_And_Analyze
6709 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
6712 -- Check for transient objects associated with Target and generate the
6713 -- appropriate finalization actions for them.
6715 Process_Transients_In_Scope
6716 (First_Object => First_Obj,
6717 Last_Object => Last_Obj,
6718 Related_Node => Target);
6720 -- Reset the action lists
6723 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
6725 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
6729 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
6731 end Insert_Actions_In_Scope_Around;
6733 ------------------------------
6734 -- Is_Simple_Protected_Type --
6735 ------------------------------
6737 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
6740 Is_Protected_Type (T)
6741 and then not Uses_Lock_Free (T)
6742 and then not Has_Entries (T)
6743 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
6744 end Is_Simple_Protected_Type;
6746 -----------------------
6747 -- Make_Adjust_Call --
6748 -----------------------
6750 function Make_Adjust_Call
6753 Skip_Self : Boolean := False) return Node_Id
6755 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6756 Adj_Id : Entity_Id := Empty;
6763 -- Recover the proper type which contains Deep_Adjust
6765 if Is_Class_Wide_Type (Typ) then
6766 Utyp := Root_Type (Typ);
6771 Utyp := Underlying_Type (Base_Type (Utyp));
6772 Set_Assignment_OK (Ref);
6774 -- Deal with untagged derivation of private views
6776 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
6777 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6778 Ref := Unchecked_Convert_To (Utyp, Ref);
6779 Set_Assignment_OK (Ref);
6782 -- When dealing with the completion of a private type, use the base
6785 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
6786 pragma Assert (Is_Private_Type (Typ));
6788 Utyp := Base_Type (Utyp);
6789 Ref := Unchecked_Convert_To (Utyp, Ref);
6792 -- The underlying type may not be present due to a missing full view. In
6793 -- this case freezing did not take place and there is no [Deep_]Adjust
6794 -- primitive to call.
6799 elsif Skip_Self then
6800 if Has_Controlled_Component (Utyp) then
6801 if Is_Tagged_Type (Utyp) then
6802 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6804 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6808 -- Class-wide types, interfaces and types with controlled components
6810 elsif Is_Class_Wide_Type (Typ)
6811 or else Is_Interface (Typ)
6812 or else Has_Controlled_Component (Utyp)
6814 if Is_Tagged_Type (Utyp) then
6815 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6817 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6820 -- Derivations from [Limited_]Controlled
6822 elsif Is_Controlled (Utyp) then
6823 if Has_Controlled_Component (Utyp) then
6824 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6826 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
6831 elsif Is_Tagged_Type (Utyp) then
6832 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6835 raise Program_Error;
6838 if Present (Adj_Id) then
6840 -- If the object is unanalyzed, set its expected type for use in
6841 -- Convert_View in case an additional conversion is needed.
6844 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
6846 Set_Etype (Ref, Typ);
6849 -- The object reference may need another conversion depending on the
6850 -- type of the formal and that of the actual.
6852 if not Is_Class_Wide_Type (Typ) then
6853 Ref := Convert_View (Adj_Id, Ref);
6860 Skip_Self => Skip_Self);
6864 end Make_Adjust_Call;
6872 Proc_Id : Entity_Id;
6874 Skip_Self : Boolean := False) return Node_Id
6876 Params : constant List_Id := New_List (Param);
6879 -- Do not apply the controlled action to the object itself by signaling
6880 -- the related routine to avoid self.
6883 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
6887 Make_Procedure_Call_Statement (Loc,
6888 Name => New_Occurrence_Of (Proc_Id, Loc),
6889 Parameter_Associations => Params);
6892 --------------------------
6893 -- Make_Deep_Array_Body --
6894 --------------------------
6896 function Make_Deep_Array_Body
6897 (Prim : Final_Primitives;
6898 Typ : Entity_Id) return List_Id
6900 function Build_Adjust_Or_Finalize_Statements
6901 (Typ : Entity_Id) return List_Id;
6902 -- Create the statements necessary to adjust or finalize an array of
6903 -- controlled elements. Generate:
6906 -- Abort : constant Boolean := Triggered_By_Abort;
6908 -- Abort : constant Boolean := False; -- no abort
6910 -- E : Exception_Occurrence;
6911 -- Raised : Boolean := False;
6914 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6915 -- ^-- in the finalization case
6917 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6919 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6923 -- if not Raised then
6925 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6932 -- if Raised and then not Abort then
6933 -- Raise_From_Controlled_Operation (E);
6937 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
6938 -- Create the statements necessary to initialize an array of controlled
6939 -- elements. Include a mechanism to carry out partial finalization if an
6940 -- exception occurs. Generate:
6943 -- Counter : Integer := 0;
6946 -- for J1 in V'Range (1) loop
6948 -- for JN in V'Range (N) loop
6950 -- [Deep_]Initialize (V (J1, ..., JN));
6952 -- Counter := Counter + 1;
6957 -- Abort : constant Boolean := Triggered_By_Abort;
6959 -- Abort : constant Boolean := False; -- no abort
6960 -- E : Exception_Occurrence;
6961 -- Raised : Boolean := False;
6968 -- V'Length (N) - Counter;
6970 -- for F1 in reverse V'Range (1) loop
6972 -- for FN in reverse V'Range (N) loop
6973 -- if Counter > 0 then
6974 -- Counter := Counter - 1;
6977 -- [Deep_]Finalize (V (F1, ..., FN));
6981 -- if not Raised then
6983 -- Save_Occurrence (E,
6984 -- Get_Current_Excep.all.all);
6993 -- if Raised and then not Abort then
6994 -- Raise_From_Controlled_Operation (E);
7003 function New_References_To
7005 Loc : Source_Ptr) return List_Id;
7006 -- Given a list of defining identifiers, return a list of references to
7007 -- the original identifiers, in the same order as they appear.
7009 -----------------------------------------
7010 -- Build_Adjust_Or_Finalize_Statements --
7011 -----------------------------------------
7013 function Build_Adjust_Or_Finalize_Statements
7014 (Typ : Entity_Id) return List_Id
7016 Comp_Typ : constant Entity_Id := Component_Type (Typ);
7017 Index_List : constant List_Id := New_List;
7018 Loc : constant Source_Ptr := Sloc (Typ);
7019 Num_Dims : constant Int := Number_Dimensions (Typ);
7021 procedure Build_Indexes;
7022 -- Generate the indexes used in the dimension loops
7028 procedure Build_Indexes is
7030 -- Generate the following identifiers:
7031 -- Jnn - for initialization
7033 for Dim in 1 .. Num_Dims loop
7034 Append_To (Index_List,
7035 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
7041 Final_Decls : List_Id := No_List;
7042 Final_Data : Finalization_Exception_Data;
7046 Core_Loop : Node_Id;
7049 Loop_Id : Entity_Id;
7052 -- Start of processing for Build_Adjust_Or_Finalize_Statements
7055 Final_Decls := New_List;
7058 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
7061 Make_Indexed_Component (Loc,
7062 Prefix => Make_Identifier (Loc, Name_V),
7063 Expressions => New_References_To (Index_List, Loc));
7064 Set_Etype (Comp_Ref, Comp_Typ);
7067 -- [Deep_]Adjust (V (J1, ..., JN))
7069 if Prim = Adjust_Case then
7070 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7073 -- [Deep_]Finalize (V (J1, ..., JN))
7075 else pragma Assert (Prim = Finalize_Case);
7076 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7079 if Present (Call) then
7081 -- Generate the block which houses the adjust or finalize call:
7084 -- <adjust or finalize call>
7088 -- if not Raised then
7090 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7094 if Exceptions_OK then
7096 Make_Block_Statement (Loc,
7097 Handled_Statement_Sequence =>
7098 Make_Handled_Sequence_Of_Statements (Loc,
7099 Statements => New_List (Call),
7100 Exception_Handlers => New_List (
7101 Build_Exception_Handler (Final_Data))));
7106 -- Generate the dimension loops starting from the innermost one
7108 -- for Jnn in [reverse] V'Range (Dim) loop
7112 J := Last (Index_List);
7114 while Present (J) and then Dim > 0 loop
7120 Make_Loop_Statement (Loc,
7122 Make_Iteration_Scheme (Loc,
7123 Loop_Parameter_Specification =>
7124 Make_Loop_Parameter_Specification (Loc,
7125 Defining_Identifier => Loop_Id,
7126 Discrete_Subtype_Definition =>
7127 Make_Attribute_Reference (Loc,
7128 Prefix => Make_Identifier (Loc, Name_V),
7129 Attribute_Name => Name_Range,
7130 Expressions => New_List (
7131 Make_Integer_Literal (Loc, Dim))),
7134 Prim = Finalize_Case)),
7136 Statements => New_List (Core_Loop),
7137 End_Label => Empty);
7142 -- Generate the block which contains the core loop, declarations
7143 -- of the abort flag, the exception occurrence, the raised flag
7144 -- and the conditional raise:
7147 -- Abort : constant Boolean := Triggered_By_Abort;
7149 -- Abort : constant Boolean := False; -- no abort
7151 -- E : Exception_Occurrence;
7152 -- Raised : Boolean := False;
7157 -- if Raised and then not Abort then
7158 -- Raise_From_Controlled_Operation (E);
7162 Stmts := New_List (Core_Loop);
7164 if Exceptions_OK then
7165 Append_To (Stmts, Build_Raise_Statement (Final_Data));
7169 Make_Block_Statement (Loc,
7170 Declarations => Final_Decls,
7171 Handled_Statement_Sequence =>
7172 Make_Handled_Sequence_Of_Statements (Loc,
7173 Statements => Stmts));
7175 -- Otherwise previous errors or a missing full view may prevent the
7176 -- proper freezing of the component type. If this is the case, there
7177 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
7180 Block := Make_Null_Statement (Loc);
7183 return New_List (Block);
7184 end Build_Adjust_Or_Finalize_Statements;
7186 ---------------------------------
7187 -- Build_Initialize_Statements --
7188 ---------------------------------
7190 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
7191 Comp_Typ : constant Entity_Id := Component_Type (Typ);
7192 Final_List : constant List_Id := New_List;
7193 Index_List : constant List_Id := New_List;
7194 Loc : constant Source_Ptr := Sloc (Typ);
7195 Num_Dims : constant Int := Number_Dimensions (Typ);
7197 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
7198 -- Generate the following assignment:
7199 -- Counter := V'Length (1) *
7201 -- V'Length (N) - Counter;
7203 -- Counter_Id denotes the entity of the counter.
7205 function Build_Finalization_Call return Node_Id;
7206 -- Generate a deep finalization call for an array element
7208 procedure Build_Indexes;
7209 -- Generate the initialization and finalization indexes used in the
7212 function Build_Initialization_Call return Node_Id;
7213 -- Generate a deep initialization call for an array element
7215 ----------------------
7216 -- Build_Assignment --
7217 ----------------------
7219 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
7224 -- Start from the first dimension and generate:
7229 Make_Attribute_Reference (Loc,
7230 Prefix => Make_Identifier (Loc, Name_V),
7231 Attribute_Name => Name_Length,
7232 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
7234 -- Process the rest of the dimensions, generate:
7235 -- Expr * V'Length (N)
7238 while Dim <= Num_Dims loop
7240 Make_Op_Multiply (Loc,
7243 Make_Attribute_Reference (Loc,
7244 Prefix => Make_Identifier (Loc, Name_V),
7245 Attribute_Name => Name_Length,
7246 Expressions => New_List (
7247 Make_Integer_Literal (Loc, Dim))));
7253 -- Counter := Expr - Counter;
7256 Make_Assignment_Statement (Loc,
7257 Name => New_Occurrence_Of (Counter_Id, Loc),
7259 Make_Op_Subtract (Loc,
7261 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
7262 end Build_Assignment;
7264 -----------------------------
7265 -- Build_Finalization_Call --
7266 -----------------------------
7268 function Build_Finalization_Call return Node_Id is
7269 Comp_Ref : constant Node_Id :=
7270 Make_Indexed_Component (Loc,
7271 Prefix => Make_Identifier (Loc, Name_V),
7272 Expressions => New_References_To (Final_List, Loc));
7275 Set_Etype (Comp_Ref, Comp_Typ);
7278 -- [Deep_]Finalize (V);
7280 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7281 end Build_Finalization_Call;
7287 procedure Build_Indexes is
7289 -- Generate the following identifiers:
7290 -- Jnn - for initialization
7291 -- Fnn - for finalization
7293 for Dim in 1 .. Num_Dims loop
7294 Append_To (Index_List,
7295 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
7297 Append_To (Final_List,
7298 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
7302 -------------------------------
7303 -- Build_Initialization_Call --
7304 -------------------------------
7306 function Build_Initialization_Call return Node_Id is
7307 Comp_Ref : constant Node_Id :=
7308 Make_Indexed_Component (Loc,
7309 Prefix => Make_Identifier (Loc, Name_V),
7310 Expressions => New_References_To (Index_List, Loc));
7313 Set_Etype (Comp_Ref, Comp_Typ);
7316 -- [Deep_]Initialize (V (J1, ..., JN));
7318 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7319 end Build_Initialization_Call;
7323 Counter_Id : Entity_Id;
7327 Final_Block : Node_Id;
7328 Final_Data : Finalization_Exception_Data;
7329 Final_Decls : List_Id := No_List;
7330 Final_Loop : Node_Id;
7331 Init_Block : Node_Id;
7332 Init_Call : Node_Id;
7333 Init_Loop : Node_Id;
7338 -- Start of processing for Build_Initialize_Statements
7341 Counter_Id := Make_Temporary (Loc, 'C');
7342 Final_Decls := New_List;
7345 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
7347 -- Generate the block which houses the finalization call, the index
7348 -- guard and the handler which triggers Program_Error later on.
7350 -- if Counter > 0 then
7351 -- Counter := Counter - 1;
7354 -- [Deep_]Finalize (V (F1, ..., FN));
7357 -- if not Raised then
7359 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7364 Fin_Stmt := Build_Finalization_Call;
7366 if Present (Fin_Stmt) then
7367 if Exceptions_OK then
7369 Make_Block_Statement (Loc,
7370 Handled_Statement_Sequence =>
7371 Make_Handled_Sequence_Of_Statements (Loc,
7372 Statements => New_List (Fin_Stmt),
7373 Exception_Handlers => New_List (
7374 Build_Exception_Handler (Final_Data))));
7377 -- This is the core of the loop, the dimension iterators are added
7378 -- one by one in reverse.
7381 Make_If_Statement (Loc,
7384 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
7385 Right_Opnd => Make_Integer_Literal (Loc, 0)),
7387 Then_Statements => New_List (
7388 Make_Assignment_Statement (Loc,
7389 Name => New_Occurrence_Of (Counter_Id, Loc),
7391 Make_Op_Subtract (Loc,
7392 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
7393 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
7395 Else_Statements => New_List (Fin_Stmt));
7397 -- Generate all finalization loops starting from the innermost
7400 -- for Fnn in reverse V'Range (Dim) loop
7404 F := Last (Final_List);
7406 while Present (F) and then Dim > 0 loop
7412 Make_Loop_Statement (Loc,
7414 Make_Iteration_Scheme (Loc,
7415 Loop_Parameter_Specification =>
7416 Make_Loop_Parameter_Specification (Loc,
7417 Defining_Identifier => Loop_Id,
7418 Discrete_Subtype_Definition =>
7419 Make_Attribute_Reference (Loc,
7420 Prefix => Make_Identifier (Loc, Name_V),
7421 Attribute_Name => Name_Range,
7422 Expressions => New_List (
7423 Make_Integer_Literal (Loc, Dim))),
7425 Reverse_Present => True)),
7427 Statements => New_List (Final_Loop),
7428 End_Label => Empty);
7433 -- Generate the block which contains the finalization loops, the
7434 -- declarations of the abort flag, the exception occurrence, the
7435 -- raised flag and the conditional raise.
7438 -- Abort : constant Boolean := Triggered_By_Abort;
7440 -- Abort : constant Boolean := False; -- no abort
7442 -- E : Exception_Occurrence;
7443 -- Raised : Boolean := False;
7449 -- V'Length (N) - Counter;
7453 -- if Raised and then not Abort then
7454 -- Raise_From_Controlled_Operation (E);
7460 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
7462 if Exceptions_OK then
7463 Append_To (Stmts, Build_Raise_Statement (Final_Data));
7464 Append_To (Stmts, Make_Raise_Statement (Loc));
7468 Make_Block_Statement (Loc,
7469 Declarations => Final_Decls,
7470 Handled_Statement_Sequence =>
7471 Make_Handled_Sequence_Of_Statements (Loc,
7472 Statements => Stmts));
7474 -- Otherwise previous errors or a missing full view may prevent the
7475 -- proper freezing of the component type. If this is the case, there
7476 -- is no [Deep_]Finalize primitive to call.
7479 Final_Block := Make_Null_Statement (Loc);
7482 -- Generate the block which contains the initialization call and
7483 -- the partial finalization code.
7486 -- [Deep_]Initialize (V (J1, ..., JN));
7488 -- Counter := Counter + 1;
7492 -- <finalization code>
7495 Init_Call := Build_Initialization_Call;
7497 -- Only create finalization block if there is a nontrivial call
7498 -- to initialization or a Default_Initial_Condition check to be
7501 if (Present (Init_Call)
7502 and then Nkind (Init_Call) /= N_Null_Statement)
7505 and then not GNATprove_Mode
7506 and then Present (DIC_Procedure (Comp_Typ))
7507 and then not Has_Null_Body (DIC_Procedure (Comp_Typ)))
7510 Init_Stmts : constant List_Id := New_List;
7513 if Present (Init_Call) then
7514 Append_To (Init_Stmts, Init_Call);
7517 if Has_DIC (Comp_Typ)
7518 and then Present (DIC_Procedure (Comp_Typ))
7522 Build_DIC_Call (Loc,
7523 Make_Indexed_Component (Loc,
7524 Prefix => Make_Identifier (Loc, Name_V),
7525 Expressions => New_References_To (Index_List, Loc)),
7530 Make_Block_Statement (Loc,
7531 Handled_Statement_Sequence =>
7532 Make_Handled_Sequence_Of_Statements (Loc,
7533 Statements => Init_Stmts,
7534 Exception_Handlers => New_List (
7535 Make_Exception_Handler (Loc,
7536 Exception_Choices => New_List (
7537 Make_Others_Choice (Loc)),
7538 Statements => New_List (Final_Block)))));
7541 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
7542 Make_Assignment_Statement (Loc,
7543 Name => New_Occurrence_Of (Counter_Id, Loc),
7546 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
7547 Right_Opnd => Make_Integer_Literal (Loc, 1))));
7549 -- Generate all initialization loops starting from the innermost
7552 -- for Jnn in V'Range (Dim) loop
7556 J := Last (Index_List);
7558 while Present (J) and then Dim > 0 loop
7564 Make_Loop_Statement (Loc,
7566 Make_Iteration_Scheme (Loc,
7567 Loop_Parameter_Specification =>
7568 Make_Loop_Parameter_Specification (Loc,
7569 Defining_Identifier => Loop_Id,
7570 Discrete_Subtype_Definition =>
7571 Make_Attribute_Reference (Loc,
7572 Prefix => Make_Identifier (Loc, Name_V),
7573 Attribute_Name => Name_Range,
7574 Expressions => New_List (
7575 Make_Integer_Literal (Loc, Dim))))),
7577 Statements => New_List (Init_Loop),
7578 End_Label => Empty);
7583 -- Generate the block which contains the counter variable and the
7584 -- initialization loops.
7587 -- Counter : Integer := 0;
7593 Make_Block_Statement (Loc,
7594 Declarations => New_List (
7595 Make_Object_Declaration (Loc,
7596 Defining_Identifier => Counter_Id,
7597 Object_Definition =>
7598 New_Occurrence_Of (Standard_Integer, Loc),
7599 Expression => Make_Integer_Literal (Loc, 0))),
7601 Handled_Statement_Sequence =>
7602 Make_Handled_Sequence_Of_Statements (Loc,
7603 Statements => New_List (Init_Loop)));
7605 if Debug_Generated_Code then
7606 Set_Debug_Info_Needed (Counter_Id);
7609 -- Otherwise previous errors or a missing full view may prevent the
7610 -- proper freezing of the component type. If this is the case, there
7611 -- is no [Deep_]Initialize primitive to call.
7614 Init_Block := Make_Null_Statement (Loc);
7617 return New_List (Init_Block);
7618 end Build_Initialize_Statements;
7620 -----------------------
7621 -- New_References_To --
7622 -----------------------
7624 function New_References_To
7626 Loc : Source_Ptr) return List_Id
7628 Refs : constant List_Id := New_List;
7633 while Present (Id) loop
7634 Append_To (Refs, New_Occurrence_Of (Id, Loc));
7639 end New_References_To;
7641 -- Start of processing for Make_Deep_Array_Body
7645 when Address_Case =>
7646 return Make_Finalize_Address_Stmts (Typ);
7651 return Build_Adjust_Or_Finalize_Statements (Typ);
7653 when Initialize_Case =>
7654 return Build_Initialize_Statements (Typ);
7656 end Make_Deep_Array_Body;
7658 --------------------
7659 -- Make_Deep_Proc --
7660 --------------------
7662 function Make_Deep_Proc
7663 (Prim : Final_Primitives;
7665 Stmts : List_Id) return Entity_Id
7667 Loc : constant Source_Ptr := Sloc (Typ);
7669 Proc_Id : Entity_Id;
7672 -- Create the object formal, generate:
7673 -- V : System.Address
7675 if Prim = Address_Case then
7676 Formals := New_List (
7677 Make_Parameter_Specification (Loc,
7678 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7680 New_Occurrence_Of (RTE (RE_Address), Loc)));
7687 Formals := New_List (
7688 Make_Parameter_Specification (Loc,
7689 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7691 Out_Present => True,
7692 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
7694 -- F : Boolean := True
7696 if Prim = Adjust_Case
7697 or else Prim = Finalize_Case
7700 Make_Parameter_Specification (Loc,
7701 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7703 New_Occurrence_Of (Standard_Boolean, Loc),
7705 New_Occurrence_Of (Standard_True, Loc)));
7710 Make_Defining_Identifier (Loc,
7711 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
7714 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
7717 -- exception -- Finalize and Adjust cases only
7718 -- raise Program_Error;
7719 -- end Deep_Initialize / Adjust / Finalize;
7723 -- procedure Finalize_Address (V : System.Address) is
7726 -- end Finalize_Address;
7729 Make_Subprogram_Body (Loc,
7731 Make_Procedure_Specification (Loc,
7732 Defining_Unit_Name => Proc_Id,
7733 Parameter_Specifications => Formals),
7735 Declarations => Empty_List,
7737 Handled_Statement_Sequence =>
7738 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
7740 -- If there are no calls to component initialization, indicate that
7741 -- the procedure is trivial, so prevent calls to it.
7743 if Is_Empty_List (Stmts)
7744 or else Nkind (First (Stmts)) = N_Null_Statement
7746 Set_Is_Trivial_Subprogram (Proc_Id);
7752 ---------------------------
7753 -- Make_Deep_Record_Body --
7754 ---------------------------
7756 function Make_Deep_Record_Body
7757 (Prim : Final_Primitives;
7759 Is_Local : Boolean := False) return List_Id
7761 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
7762 -- Build the statements necessary to adjust a record type. The type may
7763 -- have discriminants and contain variant parts. Generate:
7767 -- [Deep_]Adjust (V.Comp_1);
7769 -- when Id : others =>
7770 -- if not Raised then
7772 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7777 -- [Deep_]Adjust (V.Comp_N);
7779 -- when Id : others =>
7780 -- if not Raised then
7782 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7787 -- Deep_Adjust (V._parent, False); -- If applicable
7789 -- when Id : others =>
7790 -- if not Raised then
7792 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7798 -- Adjust (V); -- If applicable
7801 -- if not Raised then
7803 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7808 -- if Raised and then not Abort then
7809 -- Raise_From_Controlled_Operation (E);
7813 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
7814 -- Build the statements necessary to finalize a record type. The type
7815 -- may have discriminants and contain variant parts. Generate:
7818 -- Abort : constant Boolean := Triggered_By_Abort;
7820 -- Abort : constant Boolean := False; -- no abort
7821 -- E : Exception_Occurrence;
7822 -- Raised : Boolean := False;
7827 -- Finalize (V); -- If applicable
7830 -- if not Raised then
7832 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7837 -- case Variant_1 is
7839 -- case State_Counter_N => -- If Is_Local is enabled
7849 -- <<LN>> -- If Is_Local is enabled
7851 -- [Deep_]Finalize (V.Comp_N);
7854 -- if not Raised then
7856 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7862 -- [Deep_]Finalize (V.Comp_1);
7865 -- if not Raised then
7867 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7873 -- case State_Counter_1 => -- If Is_Local is enabled
7879 -- Deep_Finalize (V._parent, False); -- If applicable
7881 -- when Id : others =>
7882 -- if not Raised then
7884 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7888 -- if Raised and then not Abort then
7889 -- Raise_From_Controlled_Operation (E);
7893 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
7894 -- Given a derived tagged type Typ, traverse all components, find field
7895 -- _parent and return its type.
7897 procedure Preprocess_Components
7899 Num_Comps : out Nat;
7900 Has_POC : out Boolean);
7901 -- Examine all components in component list Comps, count all controlled
7902 -- components and determine whether at least one of them is per-object
7903 -- constrained. Component _parent is always skipped.
7905 -----------------------------
7906 -- Build_Adjust_Statements --
7907 -----------------------------
7909 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
7910 Loc : constant Source_Ptr := Sloc (Typ);
7911 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7913 Finalizer_Data : Finalization_Exception_Data;
7915 function Process_Component_List_For_Adjust
7916 (Comps : Node_Id) return List_Id;
7917 -- Build all necessary adjust statements for a single component list
7919 ---------------------------------------
7920 -- Process_Component_List_For_Adjust --
7921 ---------------------------------------
7923 function Process_Component_List_For_Adjust
7924 (Comps : Node_Id) return List_Id
7926 Stmts : constant List_Id := New_List;
7928 procedure Process_Component_For_Adjust (Decl : Node_Id);
7929 -- Process the declaration of a single controlled component
7931 ----------------------------------
7932 -- Process_Component_For_Adjust --
7933 ----------------------------------
7935 procedure Process_Component_For_Adjust (Decl : Node_Id) is
7936 Id : constant Entity_Id := Defining_Identifier (Decl);
7937 Typ : constant Entity_Id := Etype (Id);
7943 -- [Deep_]Adjust (V.Id);
7947 -- if not Raised then
7949 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7956 Make_Selected_Component (Loc,
7957 Prefix => Make_Identifier (Loc, Name_V),
7958 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7961 -- Guard against a missing [Deep_]Adjust when the component
7962 -- type was not properly frozen.
7964 if Present (Adj_Call) then
7965 if Exceptions_OK then
7967 Make_Block_Statement (Loc,
7968 Handled_Statement_Sequence =>
7969 Make_Handled_Sequence_Of_Statements (Loc,
7970 Statements => New_List (Adj_Call),
7971 Exception_Handlers => New_List (
7972 Build_Exception_Handler (Finalizer_Data))));
7975 Append_To (Stmts, Adj_Call);
7977 end Process_Component_For_Adjust;
7982 Decl_Id : Entity_Id;
7983 Decl_Typ : Entity_Id;
7988 -- Start of processing for Process_Component_List_For_Adjust
7991 -- Perform an initial check, determine the number of controlled
7992 -- components in the current list and whether at least one of them
7993 -- is per-object constrained.
7995 Preprocess_Components (Comps, Num_Comps, Has_POC);
7997 -- The processing in this routine is done in the following order:
7998 -- 1) Regular components
7999 -- 2) Per-object constrained components
8002 if Num_Comps > 0 then
8004 -- Process all regular components in order of declarations
8006 Decl := First_Non_Pragma (Component_Items (Comps));
8007 while Present (Decl) loop
8008 Decl_Id := Defining_Identifier (Decl);
8009 Decl_Typ := Etype (Decl_Id);
8011 -- Skip _parent as well as per-object constrained components
8013 if Chars (Decl_Id) /= Name_uParent
8014 and then Needs_Finalization (Decl_Typ)
8016 if Has_Access_Constraint (Decl_Id)
8017 and then No (Expression (Decl))
8021 Process_Component_For_Adjust (Decl);
8025 Next_Non_Pragma (Decl);
8028 -- Process all per-object constrained components in order of
8032 Decl := First_Non_Pragma (Component_Items (Comps));
8033 while Present (Decl) loop
8034 Decl_Id := Defining_Identifier (Decl);
8035 Decl_Typ := Etype (Decl_Id);
8039 if Chars (Decl_Id) /= Name_uParent
8040 and then Needs_Finalization (Decl_Typ)
8041 and then Has_Access_Constraint (Decl_Id)
8042 and then No (Expression (Decl))
8044 Process_Component_For_Adjust (Decl);
8047 Next_Non_Pragma (Decl);
8052 -- Process all variants, if any
8055 if Present (Variant_Part (Comps)) then
8057 Var_Alts : constant List_Id := New_List;
8061 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
8062 while Present (Var) loop
8065 -- when <discrete choices> =>
8066 -- <adjust statements>
8068 Append_To (Var_Alts,
8069 Make_Case_Statement_Alternative (Loc,
8071 New_Copy_List (Discrete_Choices (Var)),
8073 Process_Component_List_For_Adjust (
8074 Component_List (Var))));
8076 Next_Non_Pragma (Var);
8080 -- case V.<discriminant> is
8081 -- when <discrete choices 1> =>
8082 -- <adjust statements 1>
8084 -- when <discrete choices N> =>
8085 -- <adjust statements N>
8089 Make_Case_Statement (Loc,
8091 Make_Selected_Component (Loc,
8092 Prefix => Make_Identifier (Loc, Name_V),
8094 Make_Identifier (Loc,
8095 Chars => Chars (Name (Variant_Part (Comps))))),
8096 Alternatives => Var_Alts);
8100 -- Add the variant case statement to the list of statements
8102 if Present (Var_Case) then
8103 Append_To (Stmts, Var_Case);
8106 -- If the component list did not have any controlled components
8107 -- nor variants, return null.
8109 if Is_Empty_List (Stmts) then
8110 Append_To (Stmts, Make_Null_Statement (Loc));
8114 end Process_Component_List_For_Adjust;
8118 Bod_Stmts : List_Id := No_List;
8119 Finalizer_Decls : List_Id := No_List;
8122 -- Start of processing for Build_Adjust_Statements
8125 Finalizer_Decls := New_List;
8126 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
8128 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8129 Rec_Def := Record_Extension_Part (Typ_Def);
8134 -- Create an adjust sequence for all record components
8136 if Present (Component_List (Rec_Def)) then
8138 Process_Component_List_For_Adjust (Component_List (Rec_Def));
8141 -- A derived record type must adjust all inherited components. This
8142 -- action poses the following problem:
8144 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
8149 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
8151 -- Deep_Adjust (Obj._parent);
8156 -- Adjusting the derived type will invoke Adjust of the parent and
8157 -- then that of the derived type. This is undesirable because both
8158 -- routines may modify shared components. Only the Adjust of the
8159 -- derived type should be invoked.
8161 -- To prevent this double adjustment of shared components,
8162 -- Deep_Adjust uses a flag to control the invocation of Adjust:
8164 -- procedure Deep_Adjust
8165 -- (Obj : in out Some_Type;
8166 -- Flag : Boolean := True)
8174 -- When Deep_Adjust is invokes for field _parent, a value of False is
8175 -- provided for the flag:
8177 -- Deep_Adjust (Obj._parent, False);
8179 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8181 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8186 if Needs_Finalization (Par_Typ) then
8190 Make_Selected_Component (Loc,
8191 Prefix => Make_Identifier (Loc, Name_V),
8193 Make_Identifier (Loc, Name_uParent)),
8199 -- Deep_Adjust (V._parent, False);
8202 -- when Id : others =>
8203 -- if not Raised then
8205 -- Save_Occurrence (E,
8206 -- Get_Current_Excep.all.all);
8210 if Present (Call) then
8213 if Exceptions_OK then
8215 Make_Block_Statement (Loc,
8216 Handled_Statement_Sequence =>
8217 Make_Handled_Sequence_Of_Statements (Loc,
8218 Statements => New_List (Adj_Stmt),
8219 Exception_Handlers => New_List (
8220 Build_Exception_Handler (Finalizer_Data))));
8223 Prepend_To (Bod_Stmts, Adj_Stmt);
8229 -- Adjust the object. This action must be performed last after all
8230 -- components have been adjusted.
8232 if Is_Controlled (Typ) then
8238 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
8247 -- if not Raised then
8249 -- Save_Occurrence (E,
8250 -- Get_Current_Excep.all.all);
8255 if Present (Proc) then
8257 Make_Procedure_Call_Statement (Loc,
8258 Name => New_Occurrence_Of (Proc, Loc),
8259 Parameter_Associations => New_List (
8260 Make_Identifier (Loc, Name_V)));
8262 if Exceptions_OK then
8264 Make_Block_Statement (Loc,
8265 Handled_Statement_Sequence =>
8266 Make_Handled_Sequence_Of_Statements (Loc,
8267 Statements => New_List (Adj_Stmt),
8268 Exception_Handlers => New_List (
8269 Build_Exception_Handler
8270 (Finalizer_Data))));
8273 Append_To (Bod_Stmts,
8274 Make_If_Statement (Loc,
8275 Condition => Make_Identifier (Loc, Name_F),
8276 Then_Statements => New_List (Adj_Stmt)));
8281 -- At this point either all adjustment statements have been generated
8282 -- or the type is not controlled.
8284 if Is_Empty_List (Bod_Stmts) then
8285 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
8291 -- Abort : constant Boolean := Triggered_By_Abort;
8293 -- Abort : constant Boolean := False; -- no abort
8295 -- E : Exception_Occurrence;
8296 -- Raised : Boolean := False;
8299 -- <adjust statements>
8301 -- if Raised and then not Abort then
8302 -- Raise_From_Controlled_Operation (E);
8307 if Exceptions_OK then
8308 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8313 Make_Block_Statement (Loc,
8316 Handled_Statement_Sequence =>
8317 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8319 end Build_Adjust_Statements;
8321 -------------------------------
8322 -- Build_Finalize_Statements --
8323 -------------------------------
8325 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
8326 Loc : constant Source_Ptr := Sloc (Typ);
8327 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
8330 Finalizer_Data : Finalization_Exception_Data;
8332 function Process_Component_List_For_Finalize
8333 (Comps : Node_Id) return List_Id;
8334 -- Build all necessary finalization statements for a single component
8335 -- list. The statements may include a jump circuitry if flag Is_Local
8338 -----------------------------------------
8339 -- Process_Component_List_For_Finalize --
8340 -----------------------------------------
8342 function Process_Component_List_For_Finalize
8343 (Comps : Node_Id) return List_Id
8345 procedure Process_Component_For_Finalize
8350 Num_Comps : in out Nat);
8351 -- Process the declaration of a single controlled component. If
8352 -- flag Is_Local is enabled, create the corresponding label and
8353 -- jump circuitry. Alts is the list of case alternatives, Decls
8354 -- is the top level declaration list where labels are declared
8355 -- and Stmts is the list of finalization actions. Num_Comps
8356 -- denotes the current number of components needing finalization.
8358 ------------------------------------
8359 -- Process_Component_For_Finalize --
8360 ------------------------------------
8362 procedure Process_Component_For_Finalize
8367 Num_Comps : in out Nat)
8369 Id : constant Entity_Id := Defining_Identifier (Decl);
8370 Typ : constant Entity_Id := Etype (Id);
8377 Label_Id : Entity_Id;
8384 Make_Identifier (Loc,
8385 Chars => New_External_Name ('L', Num_Comps));
8386 Set_Entity (Label_Id,
8387 Make_Defining_Identifier (Loc, Chars (Label_Id)));
8388 Label := Make_Label (Loc, Label_Id);
8391 Make_Implicit_Label_Declaration (Loc,
8392 Defining_Identifier => Entity (Label_Id),
8393 Label_Construct => Label));
8400 Make_Case_Statement_Alternative (Loc,
8401 Discrete_Choices => New_List (
8402 Make_Integer_Literal (Loc, Num_Comps)),
8404 Statements => New_List (
8405 Make_Goto_Statement (Loc,
8407 New_Occurrence_Of (Entity (Label_Id), Loc)))));
8412 Append_To (Stmts, Label);
8414 -- Decrease the number of components to be processed.
8415 -- This action yields a new Label_Id in future calls.
8417 Num_Comps := Num_Comps - 1;
8422 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
8424 -- begin -- Exception handlers allowed
8425 -- [Deep_]Finalize (V.Id);
8428 -- if not Raised then
8430 -- Save_Occurrence (E,
8431 -- Get_Current_Excep.all.all);
8438 Make_Selected_Component (Loc,
8439 Prefix => Make_Identifier (Loc, Name_V),
8440 Selector_Name => Make_Identifier (Loc, Chars (Id))),
8443 -- Guard against a missing [Deep_]Finalize when the component
8444 -- type was not properly frozen.
8446 if Present (Fin_Call) then
8447 if Exceptions_OK then
8449 Make_Block_Statement (Loc,
8450 Handled_Statement_Sequence =>
8451 Make_Handled_Sequence_Of_Statements (Loc,
8452 Statements => New_List (Fin_Call),
8453 Exception_Handlers => New_List (
8454 Build_Exception_Handler (Finalizer_Data))));
8457 Append_To (Stmts, Fin_Call);
8459 end Process_Component_For_Finalize;
8464 Counter_Id : Entity_Id := Empty;
8466 Decl_Id : Entity_Id;
8467 Decl_Typ : Entity_Id;
8470 Jump_Block : Node_Id;
8472 Label_Id : Entity_Id;
8477 -- Start of processing for Process_Component_List_For_Finalize
8480 -- Perform an initial check, look for controlled and per-object
8481 -- constrained components.
8483 Preprocess_Components (Comps, Num_Comps, Has_POC);
8485 -- Create a state counter to service the current component list.
8486 -- This step is performed before the variants are inspected in
8487 -- order to generate the same state counter names as those from
8488 -- Build_Initialize_Statements.
8490 if Num_Comps > 0 and then Is_Local then
8491 Counter := Counter + 1;
8494 Make_Defining_Identifier (Loc,
8495 Chars => New_External_Name ('C', Counter));
8498 -- Process the component in the following order:
8500 -- 2) Per-object constrained components
8501 -- 3) Regular components
8503 -- Start with the variant parts
8506 if Present (Variant_Part (Comps)) then
8508 Var_Alts : constant List_Id := New_List;
8512 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
8513 while Present (Var) loop
8516 -- when <discrete choices> =>
8517 -- <finalize statements>
8519 Append_To (Var_Alts,
8520 Make_Case_Statement_Alternative (Loc,
8522 New_Copy_List (Discrete_Choices (Var)),
8524 Process_Component_List_For_Finalize (
8525 Component_List (Var))));
8527 Next_Non_Pragma (Var);
8531 -- case V.<discriminant> is
8532 -- when <discrete choices 1> =>
8533 -- <finalize statements 1>
8535 -- when <discrete choices N> =>
8536 -- <finalize statements N>
8540 Make_Case_Statement (Loc,
8542 Make_Selected_Component (Loc,
8543 Prefix => Make_Identifier (Loc, Name_V),
8545 Make_Identifier (Loc,
8546 Chars => Chars (Name (Variant_Part (Comps))))),
8547 Alternatives => Var_Alts);
8551 -- The current component list does not have a single controlled
8552 -- component, however it may contain variants. Return the case
8553 -- statement for the variants or nothing.
8555 if Num_Comps = 0 then
8556 if Present (Var_Case) then
8557 return New_List (Var_Case);
8559 return New_List (Make_Null_Statement (Loc));
8563 -- Prepare all lists
8569 -- Process all per-object constrained components in reverse order
8572 Decl := Last_Non_Pragma (Component_Items (Comps));
8573 while Present (Decl) loop
8574 Decl_Id := Defining_Identifier (Decl);
8575 Decl_Typ := Etype (Decl_Id);
8579 if Chars (Decl_Id) /= Name_uParent
8580 and then Needs_Finalization (Decl_Typ)
8581 and then Has_Access_Constraint (Decl_Id)
8582 and then No (Expression (Decl))
8584 Process_Component_For_Finalize
8585 (Decl, Alts, Decls, Stmts, Num_Comps);
8588 Prev_Non_Pragma (Decl);
8592 -- Process the rest of the components in reverse order
8594 Decl := Last_Non_Pragma (Component_Items (Comps));
8595 while Present (Decl) loop
8596 Decl_Id := Defining_Identifier (Decl);
8597 Decl_Typ := Etype (Decl_Id);
8601 if Chars (Decl_Id) /= Name_uParent
8602 and then Needs_Finalization (Decl_Typ)
8604 -- Skip per-object constrained components since they were
8605 -- handled in the above step.
8607 if Has_Access_Constraint (Decl_Id)
8608 and then No (Expression (Decl))
8612 Process_Component_For_Finalize
8613 (Decl, Alts, Decls, Stmts, Num_Comps);
8617 Prev_Non_Pragma (Decl);
8622 -- LN : label; -- If Is_Local is enabled
8627 -- case CounterX is .
8637 -- <<LN>> -- If Is_Local is enabled
8639 -- [Deep_]Finalize (V.CompY);
8641 -- when Id : others =>
8642 -- if not Raised then
8644 -- Save_Occurrence (E,
8645 -- Get_Current_Excep.all.all);
8649 -- <<L0>> -- If Is_Local is enabled
8654 -- Add the declaration of default jump location L0, its
8655 -- corresponding alternative and its place in the statements.
8657 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
8658 Set_Entity (Label_Id,
8659 Make_Defining_Identifier (Loc, Chars (Label_Id)));
8660 Label := Make_Label (Loc, Label_Id);
8662 Append_To (Decls, -- declaration
8663 Make_Implicit_Label_Declaration (Loc,
8664 Defining_Identifier => Entity (Label_Id),
8665 Label_Construct => Label));
8667 Append_To (Alts, -- alternative
8668 Make_Case_Statement_Alternative (Loc,
8669 Discrete_Choices => New_List (
8670 Make_Others_Choice (Loc)),
8672 Statements => New_List (
8673 Make_Goto_Statement (Loc,
8674 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
8676 Append_To (Stmts, Label); -- statement
8678 -- Create the jump block
8681 Make_Case_Statement (Loc,
8682 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
8683 Alternatives => Alts));
8687 Make_Block_Statement (Loc,
8688 Declarations => Decls,
8689 Handled_Statement_Sequence =>
8690 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8692 if Present (Var_Case) then
8693 return New_List (Var_Case, Jump_Block);
8695 return New_List (Jump_Block);
8697 end Process_Component_List_For_Finalize;
8701 Bod_Stmts : List_Id := No_List;
8702 Finalizer_Decls : List_Id := No_List;
8705 -- Start of processing for Build_Finalize_Statements
8708 Finalizer_Decls := New_List;
8709 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
8711 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8712 Rec_Def := Record_Extension_Part (Typ_Def);
8717 -- Create a finalization sequence for all record components
8719 if Present (Component_List (Rec_Def)) then
8721 Process_Component_List_For_Finalize (Component_List (Rec_Def));
8724 -- A derived record type must finalize all inherited components. This
8725 -- action poses the following problem:
8727 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
8732 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
8734 -- Deep_Finalize (Obj._parent);
8739 -- Finalizing the derived type will invoke Finalize of the parent and
8740 -- then that of the derived type. This is undesirable because both
8741 -- routines may modify shared components. Only the Finalize of the
8742 -- derived type should be invoked.
8744 -- To prevent this double adjustment of shared components,
8745 -- Deep_Finalize uses a flag to control the invocation of Finalize:
8747 -- procedure Deep_Finalize
8748 -- (Obj : in out Some_Type;
8749 -- Flag : Boolean := True)
8757 -- When Deep_Finalize is invoked for field _parent, a value of False
8758 -- is provided for the flag:
8760 -- Deep_Finalize (Obj._parent, False);
8762 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8764 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8769 if Needs_Finalization (Par_Typ) then
8773 Make_Selected_Component (Loc,
8774 Prefix => Make_Identifier (Loc, Name_V),
8776 Make_Identifier (Loc, Name_uParent)),
8782 -- Deep_Finalize (V._parent, False);
8785 -- when Id : others =>
8786 -- if not Raised then
8788 -- Save_Occurrence (E,
8789 -- Get_Current_Excep.all.all);
8793 if Present (Call) then
8796 if Exceptions_OK then
8798 Make_Block_Statement (Loc,
8799 Handled_Statement_Sequence =>
8800 Make_Handled_Sequence_Of_Statements (Loc,
8801 Statements => New_List (Fin_Stmt),
8802 Exception_Handlers => New_List (
8803 Build_Exception_Handler
8804 (Finalizer_Data))));
8807 Append_To (Bod_Stmts, Fin_Stmt);
8813 -- Finalize the object. This action must be performed first before
8814 -- all components have been finalized.
8816 if Is_Controlled (Typ) and then not Is_Local then
8822 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
8831 -- if not Raised then
8833 -- Save_Occurrence (E,
8834 -- Get_Current_Excep.all.all);
8839 if Present (Proc) then
8841 Make_Procedure_Call_Statement (Loc,
8842 Name => New_Occurrence_Of (Proc, Loc),
8843 Parameter_Associations => New_List (
8844 Make_Identifier (Loc, Name_V)));
8846 if Exceptions_OK then
8848 Make_Block_Statement (Loc,
8849 Handled_Statement_Sequence =>
8850 Make_Handled_Sequence_Of_Statements (Loc,
8851 Statements => New_List (Fin_Stmt),
8852 Exception_Handlers => New_List (
8853 Build_Exception_Handler
8854 (Finalizer_Data))));
8857 Prepend_To (Bod_Stmts,
8858 Make_If_Statement (Loc,
8859 Condition => Make_Identifier (Loc, Name_F),
8860 Then_Statements => New_List (Fin_Stmt)));
8865 -- At this point either all finalization statements have been
8866 -- generated or the type is not controlled.
8868 if No (Bod_Stmts) then
8869 return New_List (Make_Null_Statement (Loc));
8873 -- Abort : constant Boolean := Triggered_By_Abort;
8875 -- Abort : constant Boolean := False; -- no abort
8877 -- E : Exception_Occurrence;
8878 -- Raised : Boolean := False;
8881 -- <finalize statements>
8883 -- if Raised and then not Abort then
8884 -- Raise_From_Controlled_Operation (E);
8889 if Exceptions_OK then
8890 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8895 Make_Block_Statement (Loc,
8898 Handled_Statement_Sequence =>
8899 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8901 end Build_Finalize_Statements;
8903 -----------------------
8904 -- Parent_Field_Type --
8905 -----------------------
8907 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
8911 Field := First_Entity (Typ);
8912 while Present (Field) loop
8913 if Chars (Field) = Name_uParent then
8914 return Etype (Field);
8917 Next_Entity (Field);
8920 -- A derived tagged type should always have a parent field
8922 raise Program_Error;
8923 end Parent_Field_Type;
8925 ---------------------------
8926 -- Preprocess_Components --
8927 ---------------------------
8929 procedure Preprocess_Components
8931 Num_Comps : out Nat;
8932 Has_POC : out Boolean)
8942 Decl := First_Non_Pragma (Component_Items (Comps));
8943 while Present (Decl) loop
8944 Id := Defining_Identifier (Decl);
8947 -- Skip field _parent
8949 if Chars (Id) /= Name_uParent
8950 and then Needs_Finalization (Typ)
8952 Num_Comps := Num_Comps + 1;
8954 if Has_Access_Constraint (Id)
8955 and then No (Expression (Decl))
8961 Next_Non_Pragma (Decl);
8963 end Preprocess_Components;
8965 -- Start of processing for Make_Deep_Record_Body
8969 when Address_Case =>
8970 return Make_Finalize_Address_Stmts (Typ);
8973 return Build_Adjust_Statements (Typ);
8975 when Finalize_Case =>
8976 return Build_Finalize_Statements (Typ);
8978 when Initialize_Case =>
8980 Loc : constant Source_Ptr := Sloc (Typ);
8983 if Is_Controlled (Typ) then
8985 Make_Procedure_Call_Statement (Loc,
8988 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
8989 Parameter_Associations => New_List (
8990 Make_Identifier (Loc, Name_V))));
8996 end Make_Deep_Record_Body;
8998 ----------------------
8999 -- Make_Final_Call --
9000 ----------------------
9002 function Make_Final_Call
9005 Skip_Self : Boolean := False) return Node_Id
9007 Loc : constant Source_Ptr := Sloc (Obj_Ref);
9009 Fin_Id : Entity_Id := Empty;
9016 -- Recover the proper type which contains [Deep_]Finalize
9018 if Is_Class_Wide_Type (Typ) then
9019 Utyp := Root_Type (Typ);
9022 elsif Is_Concurrent_Type (Typ) then
9023 Utyp := Corresponding_Record_Type (Typ);
9025 Ref := Convert_Concurrent (Ref, Typ);
9027 elsif Is_Private_Type (Typ)
9028 and then Present (Underlying_Type (Typ))
9029 and then Is_Concurrent_Type (Underlying_Type (Typ))
9031 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
9033 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
9040 Utyp := Underlying_Type (Base_Type (Utyp));
9041 Set_Assignment_OK (Ref);
9043 -- Deal with untagged derivation of private views. If the parent type
9044 -- is a protected type, Deep_Finalize is found on the corresponding
9045 -- record of the ancestor.
9047 if Is_Untagged_Derivation (Typ) then
9048 if Is_Protected_Type (Typ) then
9049 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
9051 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
9053 if Is_Protected_Type (Utyp) then
9054 Utyp := Corresponding_Record_Type (Utyp);
9058 Ref := Unchecked_Convert_To (Utyp, Ref);
9059 Set_Assignment_OK (Ref);
9062 -- Deal with derived private types which do not inherit primitives from
9063 -- their parents. In this case, [Deep_]Finalize can be found in the full
9064 -- view of the parent type.
9067 and then Is_Tagged_Type (Utyp)
9068 and then Is_Derived_Type (Utyp)
9069 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
9070 and then Is_Private_Type (Etype (Utyp))
9071 and then Present (Full_View (Etype (Utyp)))
9073 Utyp := Full_View (Etype (Utyp));
9074 Ref := Unchecked_Convert_To (Utyp, Ref);
9075 Set_Assignment_OK (Ref);
9078 -- When dealing with the completion of a private type, use the base type
9081 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
9082 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
9084 Utyp := Base_Type (Utyp);
9085 Ref := Unchecked_Convert_To (Utyp, Ref);
9086 Set_Assignment_OK (Ref);
9089 -- The underlying type may not be present due to a missing full view. In
9090 -- this case freezing did not take place and there is no [Deep_]Finalize
9091 -- primitive to call.
9096 elsif Skip_Self then
9097 if Has_Controlled_Component (Utyp) then
9098 if Is_Tagged_Type (Utyp) then
9099 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9101 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
9105 -- Class-wide types, interfaces and types with controlled components
9107 elsif Is_Class_Wide_Type (Typ)
9108 or else Is_Interface (Typ)
9109 or else Has_Controlled_Component (Utyp)
9111 if Is_Tagged_Type (Utyp) then
9112 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9114 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
9117 -- Derivations from [Limited_]Controlled
9119 elsif Is_Controlled (Utyp) then
9120 if Has_Controlled_Component (Utyp) then
9121 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9123 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
9128 elsif Is_Tagged_Type (Utyp) then
9129 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9131 -- Protected types: these also require finalization even though they
9132 -- are not marked controlled explicitly.
9134 elsif Is_Protected_Type (Typ) then
9135 -- Protected objects do not need to be finalized on restricted
9138 if Restricted_Profile then
9141 -- ??? Only handle the simple case for now. Will not support a record
9142 -- or array containing protected objects.
9144 elsif Is_Simple_Protected_Type (Typ) then
9145 Fin_Id := RTE (RE_Finalize_Protection);
9147 raise Program_Error;
9150 raise Program_Error;
9153 if Present (Fin_Id) then
9155 -- When finalizing a class-wide object, do not convert to the root
9156 -- type in order to produce a dispatching call.
9158 if Is_Class_Wide_Type (Typ) then
9161 -- Ensure that a finalization routine is at least decorated in order
9162 -- to inspect the object parameter.
9164 elsif Analyzed (Fin_Id)
9165 or else Ekind (Fin_Id) = E_Procedure
9167 -- In certain cases, such as the creation of Stream_Read, the
9168 -- visible entity of the type is its full view. Since Stream_Read
9169 -- will have to create an object of type Typ, the local object
9170 -- will be finalzed by the scope finalizer generated later on. The
9171 -- object parameter of Deep_Finalize will always use the private
9172 -- view of the type. To avoid such a clash between a private and a
9173 -- full view, perform an unchecked conversion of the object
9174 -- reference to the private view.
9177 Formal_Typ : constant Entity_Id :=
9178 Etype (First_Formal (Fin_Id));
9180 if Is_Private_Type (Formal_Typ)
9181 and then Present (Full_View (Formal_Typ))
9182 and then Full_View (Formal_Typ) = Utyp
9184 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
9188 -- If the object is unanalyzed, set its expected type for use in
9189 -- Convert_View in case an additional conversion is needed.
9192 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
9194 Set_Etype (Ref, Typ);
9197 Ref := Convert_View (Fin_Id, Ref);
9204 Skip_Self => Skip_Self);
9208 end Make_Final_Call;
9210 --------------------------------
9211 -- Make_Finalize_Address_Body --
9212 --------------------------------
9214 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
9215 Is_Task : constant Boolean :=
9216 Ekind (Typ) = E_Record_Type
9217 and then Is_Concurrent_Record_Type (Typ)
9218 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
9220 Loc : constant Source_Ptr := Sloc (Typ);
9221 Proc_Id : Entity_Id;
9225 -- The corresponding records of task types are not controlled by design.
9226 -- For the sake of completeness, create an empty Finalize_Address to be
9227 -- used in task class-wide allocations.
9232 -- Nothing to do if the type is not controlled or it already has a
9233 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
9234 -- come from source. These are usually generated for completeness and
9235 -- do not need the Finalize_Address primitive.
9237 elsif not Needs_Finalization (Typ)
9238 or else Present (TSS (Typ, TSS_Finalize_Address))
9240 (Is_Class_Wide_Type (Typ)
9241 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
9242 and then not Comes_From_Source (Root_Type (Typ)))
9247 -- Do not generate Finalize_Address routine for CodePeer
9249 if CodePeer_Mode then
9254 Make_Defining_Identifier (Loc,
9255 Make_TSS_Name (Typ, TSS_Finalize_Address));
9259 -- procedure <Typ>FD (V : System.Address) is
9261 -- null; -- for tasks
9263 -- declare -- for all other types
9264 -- type Pnn is access all Typ;
9265 -- for Pnn'Storage_Size use 0;
9267 -- [Deep_]Finalize (Pnn (V).all);
9272 Stmts := New_List (Make_Null_Statement (Loc));
9274 Stmts := Make_Finalize_Address_Stmts (Typ);
9278 Make_Subprogram_Body (Loc,
9280 Make_Procedure_Specification (Loc,
9281 Defining_Unit_Name => Proc_Id,
9283 Parameter_Specifications => New_List (
9284 Make_Parameter_Specification (Loc,
9285 Defining_Identifier =>
9286 Make_Defining_Identifier (Loc, Name_V),
9288 New_Occurrence_Of (RTE (RE_Address), Loc)))),
9290 Declarations => No_List,
9292 Handled_Statement_Sequence =>
9293 Make_Handled_Sequence_Of_Statements (Loc,
9294 Statements => Stmts)));
9296 Set_TSS (Typ, Proc_Id);
9297 end Make_Finalize_Address_Body;
9299 ---------------------------------
9300 -- Make_Finalize_Address_Stmts --
9301 ---------------------------------
9303 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
9304 Loc : constant Source_Ptr := Sloc (Typ);
9307 Desig_Typ : Entity_Id;
9308 Fin_Block : Node_Id;
9311 Ptr_Typ : Entity_Id;
9314 if Is_Array_Type (Typ) then
9315 if Is_Constrained (First_Subtype (Typ)) then
9316 Desig_Typ := First_Subtype (Typ);
9318 Desig_Typ := Base_Type (Typ);
9321 -- Class-wide types of constrained root types
9323 elsif Is_Class_Wide_Type (Typ)
9324 and then Has_Discriminants (Root_Type (Typ))
9326 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
9329 Parent_Typ : Entity_Id;
9332 -- Climb the parent type chain looking for a non-constrained type
9334 Parent_Typ := Root_Type (Typ);
9335 while Parent_Typ /= Etype (Parent_Typ)
9336 and then Has_Discriminants (Parent_Typ)
9338 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
9340 Parent_Typ := Etype (Parent_Typ);
9343 -- Handle views created for tagged types with unknown
9346 if Is_Underlying_Record_View (Parent_Typ) then
9347 Parent_Typ := Underlying_Record_View (Parent_Typ);
9350 Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
9360 -- type Ptr_Typ is access all Typ;
9361 -- for Ptr_Typ'Storage_Size use 0;
9363 Ptr_Typ := Make_Temporary (Loc, 'P');
9366 Make_Full_Type_Declaration (Loc,
9367 Defining_Identifier => Ptr_Typ,
9369 Make_Access_To_Object_Definition (Loc,
9370 All_Present => True,
9371 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
9373 Make_Attribute_Definition_Clause (Loc,
9374 Name => New_Occurrence_Of (Ptr_Typ, Loc),
9375 Chars => Name_Storage_Size,
9376 Expression => Make_Integer_Literal (Loc, 0)));
9378 Obj_Expr := Make_Identifier (Loc, Name_V);
9380 -- Unconstrained arrays require special processing in order to retrieve
9381 -- the elements. To achieve this, we have to skip the dope vector which
9382 -- lays in front of the elements and then use a thin pointer to perform
9383 -- the address-to-access conversion.
9385 if Is_Array_Type (Typ)
9386 and then not Is_Constrained (First_Subtype (Typ))
9389 Dope_Id : Entity_Id;
9392 -- Ensure that Ptr_Typ a thin pointer, generate:
9393 -- for Ptr_Typ'Size use System.Address'Size;
9396 Make_Attribute_Definition_Clause (Loc,
9397 Name => New_Occurrence_Of (Ptr_Typ, Loc),
9400 Make_Integer_Literal (Loc, System_Address_Size)));
9403 -- Dnn : constant Storage_Offset :=
9404 -- Desig_Typ'Descriptor_Size / Storage_Unit;
9406 Dope_Id := Make_Temporary (Loc, 'D');
9409 Make_Object_Declaration (Loc,
9410 Defining_Identifier => Dope_Id,
9411 Constant_Present => True,
9412 Object_Definition =>
9413 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9415 Make_Op_Divide (Loc,
9417 Make_Attribute_Reference (Loc,
9418 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
9419 Attribute_Name => Name_Descriptor_Size),
9421 Make_Integer_Literal (Loc, System_Storage_Unit))));
9423 -- Shift the address from the start of the dope vector to the
9424 -- start of the elements:
9428 -- Note that this is done through a wrapper routine since RTSfind
9429 -- cannot retrieve operations with string names of the form "+".
9432 Make_Function_Call (Loc,
9434 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
9435 Parameter_Associations => New_List (
9437 New_Occurrence_Of (Dope_Id, Loc)));
9444 Make_Explicit_Dereference (Loc,
9445 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
9448 if Present (Fin_Call) then
9450 Make_Block_Statement (Loc,
9451 Declarations => Decls,
9452 Handled_Statement_Sequence =>
9453 Make_Handled_Sequence_Of_Statements (Loc,
9454 Statements => New_List (Fin_Call)));
9456 -- Otherwise previous errors or a missing full view may prevent the
9457 -- proper freezing of the designated type. If this is the case, there
9458 -- is no [Deep_]Finalize primitive to call.
9461 Fin_Block := Make_Null_Statement (Loc);
9464 return New_List (Fin_Block);
9465 end Make_Finalize_Address_Stmts;
9467 -------------------------------------
9468 -- Make_Handler_For_Ctrl_Operation --
9469 -------------------------------------
9473 -- when E : others =>
9474 -- Raise_From_Controlled_Operation (E);
9479 -- raise Program_Error [finalize raised exception];
9481 -- depending on whether Raise_From_Controlled_Operation is available
9483 function Make_Handler_For_Ctrl_Operation
9484 (Loc : Source_Ptr) return Node_Id
9487 -- Choice parameter (for the first case above)
9489 Raise_Node : Node_Id;
9490 -- Procedure call or raise statement
9493 -- Standard run-time: add choice parameter E and pass it to
9494 -- Raise_From_Controlled_Operation so that the original exception
9495 -- name and message can be recorded in the exception message for
9498 if RTE_Available (RE_Raise_From_Controlled_Operation) then
9499 E_Occ := Make_Defining_Identifier (Loc, Name_E);
9501 Make_Procedure_Call_Statement (Loc,
9504 (RTE (RE_Raise_From_Controlled_Operation), Loc),
9505 Parameter_Associations => New_List (
9506 New_Occurrence_Of (E_Occ, Loc)));
9508 -- Restricted run-time: exception messages are not supported
9513 Make_Raise_Program_Error (Loc,
9514 Reason => PE_Finalize_Raised_Exception);
9518 Make_Implicit_Exception_Handler (Loc,
9519 Exception_Choices => New_List (Make_Others_Choice (Loc)),
9520 Choice_Parameter => E_Occ,
9521 Statements => New_List (Raise_Node));
9522 end Make_Handler_For_Ctrl_Operation;
9524 --------------------
9525 -- Make_Init_Call --
9526 --------------------
9528 function Make_Init_Call
9530 Typ : Entity_Id) return Node_Id
9532 Loc : constant Source_Ptr := Sloc (Obj_Ref);
9541 -- Deal with the type and object reference. Depending on the context, an
9542 -- object reference may need several conversions.
9544 if Is_Concurrent_Type (Typ) then
9546 Utyp := Corresponding_Record_Type (Typ);
9547 Ref := Convert_Concurrent (Ref, Typ);
9549 elsif Is_Private_Type (Typ)
9550 and then Present (Full_View (Typ))
9551 and then Is_Concurrent_Type (Underlying_Type (Typ))
9554 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
9555 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
9562 Utyp := Underlying_Type (Base_Type (Utyp));
9563 Set_Assignment_OK (Ref);
9565 -- Deal with untagged derivation of private views
9567 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
9568 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
9569 Ref := Unchecked_Convert_To (Utyp, Ref);
9571 -- The following is to prevent problems with UC see 1.156 RH ???
9573 Set_Assignment_OK (Ref);
9576 -- If the underlying_type is a subtype, then we are dealing with the
9577 -- completion of a private type. We need to access the base type and
9578 -- generate a conversion to it.
9580 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
9581 pragma Assert (Is_Private_Type (Typ));
9582 Utyp := Base_Type (Utyp);
9583 Ref := Unchecked_Convert_To (Utyp, Ref);
9586 -- The underlying type may not be present due to a missing full view.
9587 -- In this case freezing did not take place and there is no suitable
9588 -- [Deep_]Initialize primitive to call.
9589 -- If Typ is protected then no additional processing is needed either.
9592 or else Is_Protected_Type (Typ)
9597 -- Select the appropriate version of initialize
9599 if Has_Controlled_Component (Utyp) then
9600 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
9602 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
9603 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
9606 -- If initialization procedure for an array of controlled objects is
9607 -- trivial, do not generate a useless call to it.
9609 if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
9611 (not Comes_From_Source (Proc)
9612 and then Present (Alias (Proc))
9613 and then Is_Trivial_Subprogram (Alias (Proc)))
9618 -- The object reference may need another conversion depending on the
9619 -- type of the formal and that of the actual.
9621 Ref := Convert_View (Proc, Ref);
9624 -- [Deep_]Initialize (Ref);
9627 Make_Procedure_Call_Statement (Loc,
9628 Name => New_Occurrence_Of (Proc, Loc),
9629 Parameter_Associations => New_List (Ref));
9632 ------------------------------
9633 -- Make_Local_Deep_Finalize --
9634 ------------------------------
9636 function Make_Local_Deep_Finalize
9638 Nam : Entity_Id) return Node_Id
9640 Loc : constant Source_Ptr := Sloc (Typ);
9644 Formals := New_List (
9648 Make_Parameter_Specification (Loc,
9649 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9651 Out_Present => True,
9652 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
9654 -- F : Boolean := True
9656 Make_Parameter_Specification (Loc,
9657 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9658 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
9659 Expression => New_Occurrence_Of (Standard_True, Loc)));
9661 -- Add the necessary number of counters to represent the initialization
9662 -- state of an object.
9665 Make_Subprogram_Body (Loc,
9667 Make_Procedure_Specification (Loc,
9668 Defining_Unit_Name => Nam,
9669 Parameter_Specifications => Formals),
9671 Declarations => No_List,
9673 Handled_Statement_Sequence =>
9674 Make_Handled_Sequence_Of_Statements (Loc,
9675 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
9676 end Make_Local_Deep_Finalize;
9678 ------------------------------------
9679 -- Make_Set_Finalize_Address_Call --
9680 ------------------------------------
9682 function Make_Set_Finalize_Address_Call
9684 Ptr_Typ : Entity_Id) return Node_Id
9686 -- It is possible for Ptr_Typ to be a partial view, if the access type
9687 -- is a full view declared in the private part of a nested package, and
9688 -- the finalization actions take place when completing analysis of the
9689 -- enclosing unit. For this reason use Underlying_Type twice below.
9691 Desig_Typ : constant Entity_Id :=
9693 (Designated_Type (Underlying_Type (Ptr_Typ)));
9694 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
9695 Fin_Mas : constant Entity_Id :=
9696 Finalization_Master (Underlying_Type (Ptr_Typ));
9699 -- Both the finalization master and primitive Finalize_Address must be
9702 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
9705 -- Set_Finalize_Address
9706 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
9709 Make_Procedure_Call_Statement (Loc,
9711 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
9712 Parameter_Associations => New_List (
9713 New_Occurrence_Of (Fin_Mas, Loc),
9715 Make_Attribute_Reference (Loc,
9716 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
9717 Attribute_Name => Name_Unrestricted_Access)));
9718 end Make_Set_Finalize_Address_Call;
9720 --------------------------
9721 -- Make_Transient_Block --
9722 --------------------------
9724 function Make_Transient_Block
9727 Par : Node_Id) return Node_Id
9729 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
9730 -- Determine whether scoping entity Id manages the secondary stack
9732 function Within_Loop_Statement (N : Node_Id) return Boolean;
9733 -- Return True when N appears within a loop and no block is containing N
9735 -----------------------
9736 -- Manages_Sec_Stack --
9737 -----------------------
9739 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
9743 -- An exception handler with a choice parameter utilizes a dummy
9744 -- block to provide a declarative region. Such a block should not
9745 -- be considered because it never manifests in the tree and can
9746 -- never release the secondary stack.
9750 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
9757 return Uses_Sec_Stack (Id);
9762 end Manages_Sec_Stack;
9764 ---------------------------
9765 -- Within_Loop_Statement --
9766 ---------------------------
9768 function Within_Loop_Statement (N : Node_Id) return Boolean is
9769 Par : Node_Id := Parent (N);
9772 while Nkind (Par) not in
9773 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9774 N_Package_Specification | N_Proper_Body
9776 pragma Assert (Present (Par));
9777 Par := Parent (Par);
9780 return Nkind (Par) = N_Loop_Statement;
9781 end Within_Loop_Statement;
9785 Decls : constant List_Id := New_List;
9786 Instrs : constant List_Id := New_List (Action);
9787 Trans_Id : constant Entity_Id := Current_Scope;
9793 -- Start of processing for Make_Transient_Block
9796 -- Even though the transient block is tasked with managing the secondary
9797 -- stack, the block may forgo this functionality depending on how the
9798 -- secondary stack is managed by enclosing scopes.
9800 if Manages_Sec_Stack (Trans_Id) then
9802 -- Determine whether an enclosing scope already manages the secondary
9805 Scop := Scope (Trans_Id);
9806 while Present (Scop) loop
9808 -- It should not be possible to reach Standard without hitting one
9809 -- of the other cases first unless Standard was manually pushed.
9811 if Scop = Standard_Standard then
9814 -- The transient block is within a function which returns on the
9815 -- secondary stack. Take a conservative approach and assume that
9816 -- the value on the secondary stack is part of the result. Note
9817 -- that it is not possible to detect this dependency without flow
9818 -- analysis which the compiler does not have. Letting the object
9819 -- live longer than the transient block will not leak any memory
9820 -- because the caller will reclaim the total storage used by the
9823 elsif Ekind (Scop) = E_Function
9824 and then Sec_Stack_Needed_For_Return (Scop)
9826 Set_Uses_Sec_Stack (Trans_Id, False);
9829 -- The transient block must manage the secondary stack when the
9830 -- block appears within a loop in order to reclaim the memory at
9833 elsif Ekind (Scop) = E_Loop then
9836 -- Ditto when the block appears without a block that does not
9837 -- manage the secondary stack and is located within a loop.
9839 elsif Ekind (Scop) = E_Block
9840 and then not Manages_Sec_Stack (Scop)
9841 and then Present (Block_Node (Scop))
9842 and then Within_Loop_Statement (Block_Node (Scop))
9846 -- The transient block does not need to manage the secondary stack
9847 -- when there is an enclosing construct which already does that.
9848 -- This optimization saves on SS_Mark and SS_Release calls but may
9849 -- allow objects to live a little longer than required.
9851 -- The transient block must manage the secondary stack when switch
9852 -- -gnatd.s (strict management) is in effect.
9854 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
9855 Set_Uses_Sec_Stack (Trans_Id, False);
9858 -- Prevent the search from going too far because transient blocks
9859 -- are bounded by packages and subprogram scopes.
9861 elsif Ekind (Scop) in E_Entry
9871 Scop := Scope (Scop);
9875 -- Create the transient block. Set the parent now since the block itself
9876 -- is not part of the tree. The current scope is the E_Block entity that
9877 -- has been pushed by Establish_Transient_Scope.
9879 pragma Assert (Ekind (Trans_Id) = E_Block);
9882 Make_Block_Statement (Loc,
9883 Identifier => New_Occurrence_Of (Trans_Id, Loc),
9884 Declarations => Decls,
9885 Handled_Statement_Sequence =>
9886 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
9887 Has_Created_Identifier => True);
9888 Set_Parent (Block, Par);
9890 -- Insert actions stuck in the transient scopes as well as all freezing
9891 -- nodes needed by those actions. Do not insert cleanup actions here,
9892 -- they will be transferred to the newly created block.
9894 Insert_Actions_In_Scope_Around
9895 (Action, Clean => False, Manage_SS => False);
9897 Insert := Prev (Action);
9899 if Present (Insert) then
9900 Freeze_All (First_Entity (Trans_Id), Insert);
9903 -- Transfer cleanup actions to the newly created block
9906 Cleanup_Actions : List_Id
9907 renames Scope_Stack.Table (Scope_Stack.Last).
9908 Actions_To_Be_Wrapped (Cleanup);
9910 Set_Cleanup_Actions (Block, Cleanup_Actions);
9911 Cleanup_Actions := No_List;
9914 -- When the transient scope was established, we pushed the entry for the
9915 -- transient scope onto the scope stack, so that the scope was active
9916 -- for the installation of finalizable entities etc. Now we must remove
9917 -- this entry, since we have constructed a proper block.
9922 end Make_Transient_Block;
9924 ------------------------
9925 -- Node_To_Be_Wrapped --
9926 ------------------------
9928 function Node_To_Be_Wrapped return Node_Id is
9930 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
9931 end Node_To_Be_Wrapped;
9933 ----------------------------
9934 -- Set_Node_To_Be_Wrapped --
9935 ----------------------------
9937 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
9939 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
9940 end Set_Node_To_Be_Wrapped;
9942 ----------------------------
9943 -- Store_Actions_In_Scope --
9944 ----------------------------
9946 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
9947 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
9948 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
9951 if Is_Empty_List (Actions) then
9954 if Is_List_Member (SE.Node_To_Be_Wrapped) then
9955 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
9957 Set_Parent (L, SE.Node_To_Be_Wrapped);
9962 elsif AK = Before then
9963 Insert_List_After_And_Analyze (Last (Actions), L);
9966 Insert_List_Before_And_Analyze (First (Actions), L);
9968 end Store_Actions_In_Scope;
9970 ----------------------------------
9971 -- Store_After_Actions_In_Scope --
9972 ----------------------------------
9974 procedure Store_After_Actions_In_Scope (L : List_Id) is
9976 Store_Actions_In_Scope (After, L);
9977 end Store_After_Actions_In_Scope;
9979 -----------------------------------
9980 -- Store_Before_Actions_In_Scope --
9981 -----------------------------------
9983 procedure Store_Before_Actions_In_Scope (L : List_Id) is
9985 Store_Actions_In_Scope (Before, L);
9986 end Store_Before_Actions_In_Scope;
9988 -----------------------------------
9989 -- Store_Cleanup_Actions_In_Scope --
9990 -----------------------------------
9992 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
9994 Store_Actions_In_Scope (Cleanup, L);
9995 end Store_Cleanup_Actions_In_Scope;
10001 procedure Unnest_Block (Decl : Node_Id) is
10002 Loc : constant Source_Ptr := Sloc (Decl);
10004 Local_Body : Node_Id;
10005 Local_Call : Node_Id;
10006 Local_Proc : Entity_Id;
10007 Local_Scop : Entity_Id;
10010 Local_Scop := Entity (Identifier (Decl));
10011 Ent := First_Entity (Local_Scop);
10014 Make_Defining_Identifier (Loc,
10015 Chars => New_Internal_Name ('P'));
10018 Make_Subprogram_Body (Loc,
10020 Make_Procedure_Specification (Loc,
10021 Defining_Unit_Name => Local_Proc),
10022 Declarations => Declarations (Decl),
10023 Handled_Statement_Sequence =>
10024 Handled_Statement_Sequence (Decl));
10026 -- Handlers in the block may contain nested subprograms that require
10029 Check_Unnesting_In_Handlers (Local_Body);
10031 Rewrite (Decl, Local_Body);
10033 Set_Has_Nested_Subprogram (Local_Proc);
10036 Make_Procedure_Call_Statement (Loc,
10037 Name => New_Occurrence_Of (Local_Proc, Loc));
10039 Insert_After (Decl, Local_Call);
10040 Analyze (Local_Call);
10042 -- The new subprogram has the same scope as the original block
10044 Set_Scope (Local_Proc, Scope (Local_Scop));
10046 -- And the entity list of the new procedure is that of the block
10048 Set_First_Entity (Local_Proc, Ent);
10050 -- Reset the scopes of all the entities to the new procedure
10052 while Present (Ent) loop
10053 Set_Scope (Ent, Local_Proc);
10058 -------------------------
10059 -- Unnest_If_Statement --
10060 -------------------------
10062 procedure Unnest_If_Statement (If_Stmt : Node_Id) is
10064 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id);
10065 -- A list of statements (that may be a list associated with a then,
10066 -- elsif, or else part of an if-statement) is traversed at the top
10067 -- level to determine whether it contains a subprogram body, and if so,
10068 -- the statements will be replaced with a new procedure body containing
10069 -- the statements followed by a call to the procedure. The individual
10070 -- statements may also be blocks, loops, or other if statements that
10071 -- themselves may require contain nested subprograms needing unnesting.
10073 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is
10074 Subp_Found : Boolean := False;
10077 if Is_Empty_List (Stmts) then
10082 Stmt : Node_Id := First (Stmts);
10084 while Present (Stmt) loop
10085 if Nkind (Stmt) = N_Subprogram_Body then
10086 Subp_Found := True;
10094 -- The statements themselves may be blocks, loops, etc. that in turn
10095 -- contain nested subprograms requiring an unnesting transformation.
10096 -- We perform this traversal after looking for subprogram bodies, to
10097 -- avoid considering procedures created for one of those statements
10098 -- (such as a block rewritten as a procedure) as a nested subprogram
10099 -- of the statement list (which could result in an unneeded wrapper
10102 Check_Unnesting_In_Decls_Or_Stmts (Stmts);
10104 -- If there was a top-level subprogram body in the statement list,
10105 -- then perform an unnesting transformation on the list by replacing
10106 -- the statements with a wrapper procedure body containing the
10107 -- original statements followed by a call to that procedure.
10110 Unnest_Statement_List (Stmts);
10112 end Check_Stmts_For_Subp_Unnesting;
10116 Then_Stmts : List_Id := Then_Statements (If_Stmt);
10117 Else_Stmts : List_Id := Else_Statements (If_Stmt);
10119 -- Start of processing for Unnest_If_Statement
10122 Check_Stmts_For_Subp_Unnesting (Then_Stmts);
10123 Set_Then_Statements (If_Stmt, Then_Stmts);
10125 if not Is_Empty_List (Elsif_Parts (If_Stmt)) then
10127 Elsif_Part : Node_Id :=
10128 First (Elsif_Parts (If_Stmt));
10129 Elsif_Stmts : List_Id;
10131 while Present (Elsif_Part) loop
10132 Elsif_Stmts := Then_Statements (Elsif_Part);
10134 Check_Stmts_For_Subp_Unnesting (Elsif_Stmts);
10135 Set_Then_Statements (Elsif_Part, Elsif_Stmts);
10142 Check_Stmts_For_Subp_Unnesting (Else_Stmts);
10143 Set_Else_Statements (If_Stmt, Else_Stmts);
10144 end Unnest_If_Statement;
10150 procedure Unnest_Loop (Loop_Stmt : Node_Id) is
10151 Loc : constant Source_Ptr := Sloc (Loop_Stmt);
10153 Local_Body : Node_Id;
10154 Local_Call : Node_Id;
10155 Local_Proc : Entity_Id;
10156 Local_Scop : Entity_Id;
10157 Loop_Copy : constant Node_Id :=
10158 Relocate_Node (Loop_Stmt);
10160 Local_Scop := Entity (Identifier (Loop_Stmt));
10161 Ent := First_Entity (Local_Scop);
10164 Make_Defining_Identifier (Loc,
10165 Chars => New_Internal_Name ('P'));
10168 Make_Subprogram_Body (Loc,
10170 Make_Procedure_Specification (Loc,
10171 Defining_Unit_Name => Local_Proc),
10172 Declarations => Empty_List,
10173 Handled_Statement_Sequence =>
10174 Make_Handled_Sequence_Of_Statements (Loc,
10175 Statements => New_List (Loop_Copy)));
10177 Set_First_Real_Statement
10178 (Handled_Statement_Sequence (Local_Body), Loop_Copy);
10180 Rewrite (Loop_Stmt, Local_Body);
10181 Analyze (Loop_Stmt);
10183 Set_Has_Nested_Subprogram (Local_Proc);
10186 Make_Procedure_Call_Statement (Loc,
10187 Name => New_Occurrence_Of (Local_Proc, Loc));
10189 Insert_After (Loop_Stmt, Local_Call);
10190 Analyze (Local_Call);
10192 -- New procedure has the same scope as the original loop, and the scope
10193 -- of the loop is the new procedure.
10195 Set_Scope (Local_Proc, Scope (Local_Scop));
10196 Set_Scope (Local_Scop, Local_Proc);
10198 -- The entity list of the new procedure is that of the loop
10200 Set_First_Entity (Local_Proc, Ent);
10202 -- Note that the entities associated with the loop don't need to have
10203 -- their Scope fields reset, since they're still associated with the
10204 -- same loop entity that now belongs to the copied loop statement.
10207 ---------------------------
10208 -- Unnest_Statement_List --
10209 ---------------------------
10211 procedure Unnest_Statement_List (Stmts : in out List_Id) is
10212 Loc : constant Source_Ptr := Sloc (First (Stmts));
10213 Local_Body : Node_Id;
10214 Local_Call : Node_Id;
10215 Local_Proc : Entity_Id;
10216 New_Stmts : constant List_Id := Empty_List;
10220 Make_Defining_Identifier (Loc,
10221 Chars => New_Internal_Name ('P'));
10224 Make_Subprogram_Body (Loc,
10226 Make_Procedure_Specification (Loc,
10227 Defining_Unit_Name => Local_Proc),
10228 Declarations => Empty_List,
10229 Handled_Statement_Sequence =>
10230 Make_Handled_Sequence_Of_Statements (Loc,
10231 Statements => Stmts));
10233 Append_To (New_Stmts, Local_Body);
10235 Analyze (Local_Body);
10237 Set_Has_Nested_Subprogram (Local_Proc);
10240 Make_Procedure_Call_Statement (Loc,
10241 Name => New_Occurrence_Of (Local_Proc, Loc));
10243 Append_To (New_Stmts, Local_Call);
10244 Analyze (Local_Call);
10246 -- Traverse the statements, and for any that are declarations or
10247 -- subprogram bodies that have entities, set the Scope of those
10248 -- entities to the new procedure's Entity_Id.
10251 Stmt : Node_Id := First (Stmts);
10254 while Present (Stmt) loop
10255 case Nkind (Stmt) is
10257 | N_Renaming_Declaration
10259 Set_Scope (Defining_Identifier (Stmt), Local_Proc);
10261 when N_Subprogram_Body =>
10263 (Defining_Unit_Name (Specification (Stmt)), Local_Proc);
10273 Stmts := New_Stmts;
10274 end Unnest_Statement_List;
10276 --------------------------------
10277 -- Wrap_Transient_Declaration --
10278 --------------------------------
10280 -- If a transient scope has been established during the processing of the
10281 -- Expression of an Object_Declaration, it is not possible to wrap the
10282 -- declaration into a transient block as usual case, otherwise the object
10283 -- would be itself declared in the wrong scope. Therefore, all entities (if
10284 -- any) defined in the transient block are moved to the proper enclosing
10285 -- scope. Furthermore, if they are controlled variables they are finalized
10286 -- right after the declaration. The finalization list of the transient
10287 -- scope is defined as a renaming of the enclosing one so during their
10288 -- initialization they will be attached to the proper finalization list.
10289 -- For instance, the following declaration :
10291 -- X : Typ := F (G (A), G (B));
10293 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
10294 -- is expanded into :
10296 -- X : Typ := [ complex Expression-Action ];
10297 -- [Deep_]Finalize (_v1);
10298 -- [Deep_]Finalize (_v2);
10300 procedure Wrap_Transient_Declaration (N : Node_Id) is
10301 Curr_S : Entity_Id;
10302 Encl_S : Entity_Id;
10305 Curr_S := Current_Scope;
10306 Encl_S := Scope (Curr_S);
10308 -- Insert all actions including cleanup generated while analyzing or
10309 -- expanding the transient context back into the tree. Manage the
10310 -- secondary stack when the object declaration appears in a library
10311 -- level package [body].
10313 Insert_Actions_In_Scope_Around
10317 Uses_Sec_Stack (Curr_S)
10318 and then Nkind (N) = N_Object_Declaration
10319 and then Ekind (Encl_S) in E_Package | E_Package_Body
10320 and then Is_Library_Level_Entity (Encl_S));
10323 -- Relocate local entities declared within the transient scope to the
10324 -- enclosing scope. This action sets their Is_Public flag accordingly.
10326 Transfer_Entities (Curr_S, Encl_S);
10328 -- Mark the enclosing dynamic scope to ensure that the secondary stack
10329 -- is properly released upon exiting the said scope.
10331 if Uses_Sec_Stack (Curr_S) then
10332 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
10334 -- Do not mark a function that returns on the secondary stack as the
10335 -- reclamation is done by the caller.
10337 if Ekind (Curr_S) = E_Function
10338 and then Requires_Transient_Scope (Etype (Curr_S))
10342 -- Otherwise mark the enclosing dynamic scope
10345 Set_Uses_Sec_Stack (Curr_S);
10346 Check_Restriction (No_Secondary_Stack, N);
10349 end Wrap_Transient_Declaration;
10351 -------------------------------
10352 -- Wrap_Transient_Expression --
10353 -------------------------------
10355 procedure Wrap_Transient_Expression (N : Node_Id) is
10356 Loc : constant Source_Ptr := Sloc (N);
10357 Expr : Node_Id := Relocate_Node (N);
10358 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
10359 Typ : constant Entity_Id := Etype (N);
10366 -- M : constant Mark_Id := SS_Mark;
10367 -- procedure Finalizer is ... (See Build_Finalizer)
10370 -- Temp := <Expr>; -- general case
10371 -- Temp := (if <Expr> then True else False); -- boolean case
10377 -- A special case is made for Boolean expressions so that the back end
10378 -- knows to generate a conditional branch instruction, if running with
10379 -- -fpreserve-control-flow. This ensures that a control-flow change
10380 -- signaling the decision outcome occurs before the cleanup actions.
10382 if Opt.Suppress_Control_Flow_Optimizations
10383 and then Is_Boolean_Type (Typ)
10386 Make_If_Expression (Loc,
10387 Expressions => New_List (
10389 New_Occurrence_Of (Standard_True, Loc),
10390 New_Occurrence_Of (Standard_False, Loc)));
10393 Insert_Actions (N, New_List (
10394 Make_Object_Declaration (Loc,
10395 Defining_Identifier => Temp,
10396 Object_Definition => New_Occurrence_Of (Typ, Loc)),
10398 Make_Transient_Block (Loc,
10400 Make_Assignment_Statement (Loc,
10401 Name => New_Occurrence_Of (Temp, Loc),
10402 Expression => Expr),
10403 Par => Parent (N))));
10405 if Debug_Generated_Code then
10406 Set_Debug_Info_Needed (Temp);
10409 Rewrite (N, New_Occurrence_Of (Temp, Loc));
10410 Analyze_And_Resolve (N, Typ);
10411 end Wrap_Transient_Expression;
10413 ------------------------------
10414 -- Wrap_Transient_Statement --
10415 ------------------------------
10417 procedure Wrap_Transient_Statement (N : Node_Id) is
10418 Loc : constant Source_Ptr := Sloc (N);
10419 New_Stmt : constant Node_Id := Relocate_Node (N);
10424 -- M : constant Mark_Id := SS_Mark;
10425 -- procedure Finalizer is ... (See Build_Finalizer)
10435 Make_Transient_Block (Loc,
10436 Action => New_Stmt,
10437 Par => Parent (N)));
10439 -- With the scope stack back to normal, we can call analyze on the
10440 -- resulting block. At this point, the transient scope is being
10441 -- treated like a perfectly normal scope, so there is nothing
10442 -- special about it.
10444 -- Note: Wrap_Transient_Statement is called with the node already
10445 -- analyzed (i.e. Analyzed (N) is True). This is important, since
10446 -- otherwise we would get a recursive processing of the node when
10447 -- we do this Analyze call.
10450 end Wrap_Transient_Statement;