1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree; use Atree;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Einfo.Entities; use Einfo.Entities;
34 with Einfo.Utils; use Einfo.Utils;
35 with Elists; use Elists;
36 with Errout; use Errout;
37 with Exp_Ch6; use Exp_Ch6;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Ch11; use Exp_Ch11;
40 with Exp_Dbug; use Exp_Dbug;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Disp; use Exp_Disp;
43 with Exp_Prag; use Exp_Prag;
44 with Exp_Tss; use Exp_Tss;
45 with Exp_Util; use Exp_Util;
46 with Freeze; use Freeze;
47 with GNAT_CUDA; use GNAT_CUDA;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
52 with Output; use Output;
53 with Restrict; use Restrict;
54 with Rident; use Rident;
55 with Rtsfind; use Rtsfind;
56 with Sinfo; use Sinfo;
57 with Sinfo.Nodes; use Sinfo.Nodes;
58 with Sinfo.Utils; use Sinfo.Utils;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch7; use Sem_Ch7;
62 with Sem_Ch8; use Sem_Ch8;
63 with Sem_Res; use Sem_Res;
64 with Sem_Util; use Sem_Util;
65 with Snames; use Snames;
66 with Stand; use Stand;
67 with Tbuild; use Tbuild;
68 with Ttypes; use Ttypes;
69 with Uintp; use Uintp;
71 package body Exp_Ch7 is
73 --------------------------------
74 -- Transient Scope Management --
75 --------------------------------
77 -- A transient scope is needed when certain temporary objects are created
78 -- by the compiler. These temporary objects are allocated on the secondary
79 -- stack and/or need finalization, and the transient scope is responsible
80 -- for finalizing the objects and reclaiming the memory of the secondary
81 -- stack at the appropriate time. They are generally objects allocated to
82 -- store the result of a function returning an unconstrained or controlled
83 -- value. Expressions needing to be wrapped in a transient scope may appear
84 -- in three different contexts which lead to different kinds of transient
87 -- 1. In a simple statement (procedure call, assignment, ...). In this
88 -- case the instruction is wrapped into a transient block. See
89 -- Wrap_Transient_Statement for details.
91 -- 2. In an expression of a control structure (test in a IF statement,
92 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
95 -- 3. In a expression of an object_declaration. No wrapping is possible
96 -- here, so the finalization actions, if any, are done right after the
97 -- declaration and the secondary stack deallocation is done in the
98 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
100 --------------------------------------------------
101 -- Transient Blocks and Finalization Management --
102 --------------------------------------------------
104 procedure Insert_Actions_In_Scope_Around
107 Manage_SS : Boolean);
108 -- Insert the before-actions kept in the scope stack before N, and the
109 -- after-actions after N, which must be a member of a list. If flag Clean
110 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
111 -- calls to mark and release the secondary stack.
113 function Make_Transient_Block
116 Par : Node_Id) return Node_Id;
117 -- Action is a single statement or object declaration. Par is the proper
118 -- parent of the generated block. Create a transient block whose name is
119 -- the current scope and the only handled statement is Action. If Action
120 -- involves controlled objects or secondary stack usage, the corresponding
121 -- cleanup actions are performed at the end of the block.
123 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
124 -- Shared processing for Store_xxx_Actions_In_Scope
126 -----------------------------
127 -- Finalization Management --
128 -----------------------------
130 -- This part describes how Initialization/Adjustment/Finalization
131 -- procedures are generated and called. Two cases must be considered: types
132 -- that are Controlled (Is_Controlled flag set) and composite types that
133 -- contain controlled components (Has_Controlled_Component flag set). In
134 -- the first case the procedures to call are the user-defined primitive
135 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
136 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
137 -- charge of calling the former procedures on the controlled components.
139 -- For records with Has_Controlled_Component set, a hidden "controller"
140 -- component is inserted. This controller component contains its own
141 -- finalization list on which all controlled components are attached
142 -- creating an indirection on the upper-level Finalization list. This
143 -- technique facilitates the management of objects whose number of
144 -- controlled components changes during execution. This controller
145 -- component is itself controlled and is attached to the upper-level
146 -- finalization chain. Its adjust primitive is in charge of calling adjust
147 -- on the components and adjusting the finalization pointer to match their
148 -- new location (see a-finali.adb).
150 -- It is not possible to use a similar technique for arrays that have
151 -- Has_Controlled_Component set. In this case, deep procedures are
152 -- generated that call initialize/adjust/finalize + attachment or
153 -- detachment on the finalization list for all component.
155 -- Initialize calls: they are generated for declarations or dynamic
156 -- allocations of Controlled objects with no initial value. They are always
157 -- followed by an attachment to the current Finalization Chain. For the
158 -- dynamic allocation case this the chain attached to the scope of the
159 -- access type definition otherwise, this is the chain of the current
162 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
163 -- or dynamic allocations of Controlled objects with an initial value.
164 -- (2) after an assignment. In the first case they are followed by an
165 -- attachment to the final chain, in the second case they are not.
167 -- Finalization Calls: They are generated on (1) scope exit, (2)
168 -- assignments, (3) unchecked deallocations. In case (3) they have to
169 -- be detached from the final chain, in case (2) they must not and in
170 -- case (1) this is not important since we are exiting the scope anyway.
174 -- Type extensions will have a new record controller at each derivation
175 -- level containing controlled components. The record controller for
176 -- the parent/ancestor is attached to the finalization list of the
177 -- extension's record controller (i.e. the parent is like a component
178 -- of the extension).
180 -- For types that are both Is_Controlled and Has_Controlled_Components,
181 -- the record controller and the object itself are handled separately.
182 -- It could seem simpler to attach the object at the end of its record
183 -- controller but this would not tackle view conversions properly.
185 -- A classwide type can always potentially have controlled components
186 -- but the record controller of the corresponding actual type may not
187 -- be known at compile time so the dispatch table contains a special
188 -- field that allows computation of the offset of the record controller
189 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
191 -- Here is a simple example of the expansion of a controlled block :
195 -- Y : Controlled := Init;
201 -- Z : R := (C => X);
211 -- _L : System.FI.Finalizable_Ptr;
213 -- procedure _Clean is
216 -- System.FI.Finalize_List (_L);
224 -- Attach_To_Final_List (_L, Finalizable (X), 1);
225 -- at end: Abort_Undefer;
226 -- Y : Controlled := Init;
228 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
236 -- Deep_Initialize (W, _L, 1);
237 -- at end: Abort_Under;
238 -- Z : R := (C => X);
239 -- Deep_Adjust (Z, _L, 1);
243 -- Deep_Finalize (W, False);
244 -- <save W's final pointers>
246 -- <restore W's final pointers>
247 -- Deep_Adjust (W, _L, 0);
252 type Final_Primitives is
253 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
254 -- This enumeration type is defined in order to ease sharing code for
255 -- building finalization procedures for composite types.
257 Name_Of : constant array (Final_Primitives) of Name_Id :=
258 (Initialize_Case => Name_Initialize,
259 Adjust_Case => Name_Adjust,
260 Finalize_Case => Name_Finalize,
261 Address_Case => Name_Finalize_Address);
262 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
263 (Initialize_Case => TSS_Deep_Initialize,
264 Adjust_Case => TSS_Deep_Adjust,
265 Finalize_Case => TSS_Deep_Finalize,
266 Address_Case => TSS_Finalize_Address);
268 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
269 -- Determine whether access type Typ may have a finalization master
271 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
272 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
273 -- Has_Controlled_Component set and store them using the TSS mechanism.
275 function Build_Cleanup_Statements
277 Additional_Cleanup : List_Id) return List_Id;
278 -- Create the cleanup calls for an asynchronous call block, task master,
279 -- protected subprogram body, task allocation block or task body, or
280 -- additional cleanup actions parked on a transient block. If the context
281 -- does not contain the above constructs, the routine returns an empty
284 procedure Build_Finalizer
286 Clean_Stmts : List_Id;
289 Defer_Abort : Boolean;
290 Fin_Id : out Entity_Id);
291 -- N may denote an accept statement, block, entry body, package body,
292 -- package spec, protected body, subprogram body, or a task body. Create
293 -- a procedure which contains finalization calls for all controlled objects
294 -- declared in the declarative or statement region of N. The calls are
295 -- built in reverse order relative to the original declarations. In the
296 -- case of a task body, the routine delays the creation of the finalizer
297 -- until all statements have been moved to the task body procedure.
298 -- Clean_Stmts may contain additional context-dependent code used to abort
299 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
300 -- Mark_Id is the secondary stack used in the current context or Empty if
301 -- missing. Top_Decls is the list on which the declaration of the finalizer
302 -- is attached in the non-package case. Defer_Abort indicates that the
303 -- statements passed in perform actions that require abort to be deferred,
304 -- such as for task termination. Fin_Id is the finalizer declaration
307 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
308 -- N is a construct that contains a handled sequence of statements, Fin_Id
309 -- is the entity of a finalizer. Create an At_End handler that covers the
310 -- statements of N and calls Fin_Id. If the handled statement sequence has
311 -- an exception handler, the statements will be wrapped in a block to avoid
312 -- unwanted interaction with the new At_End handler.
314 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
315 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
316 -- Has_Component_Component set and store them using the TSS mechanism.
318 -------------------------------------------
319 -- Unnesting procedures for CCG and LLVM --
320 -------------------------------------------
322 -- Expansion generates subprograms for controlled types management that
323 -- may appear in declarative lists in package declarations and bodies.
324 -- These subprograms appear within generated blocks that contain local
325 -- declarations and a call to finalization procedures. To ensure that
326 -- such subprograms get activation records when needed, we transform the
327 -- block into a procedure body, followed by a call to it in the same
330 procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
331 -- The statement part of a package body that is a compilation unit may
332 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
333 -- Mode such subprograms must be handled as nested inside the (implicit)
334 -- elaboration procedure that executes that statement part. To handle
335 -- properly uplevel references we construct that subprogram explicitly,
336 -- to contain blocks and inner subprograms, the statement part becomes
337 -- a call to this subprogram. This is only done if blocks are present
338 -- in the statement list of the body. (It would be nice to unify this
339 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
340 -- they're doing very similar work, but are structured differently. ???)
342 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
343 -- Similarly, the declarations or statements in library-level packages may
344 -- have created blocks with nested subprograms. Such a block must be
345 -- transformed into a procedure followed by a call to it, so that unnesting
346 -- can handle uplevel references within these nested subprograms (typically
347 -- subprograms that handle finalization actions). This also applies to
348 -- nested packages, including instantiations, in which case it must
349 -- recursively process inner bodies.
351 procedure Check_Unnesting_In_Handlers (N : Node_Id);
352 -- Similarly, check for blocks with nested subprograms occurring within
353 -- a set of exception handlers associated with a package body N.
355 procedure Unnest_Block (Decl : Node_Id);
356 -- Blocks that contain nested subprograms with up-level references need to
357 -- create activation records for them. We do this by rewriting the block as
358 -- a procedure, followed by a call to it in the same declarative list, to
359 -- replicate the semantics of the original block.
361 -- A common source for such block is a transient block created for a
362 -- construct (declaration, assignment, etc.) that involves controlled
363 -- actions or secondary-stack management, in which case the nested
364 -- subprogram is a finalizer.
366 procedure Unnest_If_Statement (If_Stmt : Node_Id);
367 -- The separate statement lists associated with an if-statement (then part,
368 -- elsif parts, else part) may require unnesting if they directly contain
369 -- a subprogram body that references up-level objects. Each statement list
370 -- is traversed to locate such subprogram bodies, and if a part's statement
371 -- list contains a body, then the list is replaced with a new procedure
372 -- containing the part's statements followed by a call to the procedure.
373 -- Furthermore, any nested blocks, loops, or if statements will also be
374 -- traversed to determine the need for further unnesting transformations.
376 procedure Unnest_Statement_List (Stmts : in out List_Id);
377 -- A list of statements that directly contains a subprogram at its outer
378 -- level, that may reference objects declared in that same statement list,
379 -- is rewritten as a procedure containing the statement list Stmts (which
380 -- includes any such objects as well as the nested subprogram), followed by
381 -- a call to the new procedure, and Stmts becomes the list containing the
382 -- procedure and the call. This ensures that Unnest_Subprogram will later
383 -- properly handle up-level references from the nested subprogram to
384 -- objects declared earlier in statement list, by creating an activation
385 -- record and passing it to the nested subprogram. This procedure also
386 -- resets the Scope of objects declared in the statement list, as well as
387 -- the Scope of the nested subprogram, to refer to the new procedure.
388 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
389 -- only be called when known that the statement list contains a subprogram.
391 procedure Unnest_Loop (Loop_Stmt : Node_Id);
392 -- Top-level Loops that contain nested subprograms with up-level references
393 -- need to have activation records. We do this by rewriting the loop as a
394 -- procedure containing the loop, followed by a call to the procedure in
395 -- the same library-level declarative list, to replicate the semantics of
396 -- the original loop. Such loops can occur due to aggregate expansions and
399 procedure Check_Visibly_Controlled
400 (Prim : Final_Primitives;
402 E : in out Entity_Id;
403 Cref : in out Node_Id);
404 -- The controlled operation declared for a derived type may not be
405 -- overriding, if the controlled operations of the parent type are hidden,
406 -- for example when the parent is a private type whose full view is
407 -- controlled. For other primitive operations we modify the name of the
408 -- operation to indicate that it is not overriding, but this is not
409 -- possible for Initialize, etc. because they have to be retrievable by
410 -- name. Before generating the proper call to one of these operations we
411 -- check whether Typ is known to be controlled at the point of definition.
412 -- If it is not then we must retrieve the hidden operation of the parent
413 -- and use it instead. This is one case that might be solved more cleanly
414 -- once Overriding pragmas or declarations are in place.
416 function Contains_Subprogram (Blk : Entity_Id) return Boolean;
417 -- Check recursively whether a loop or block contains a subprogram that
418 -- may need an activation record.
420 function Convert_View
423 Ind : Pos := 1) return Node_Id;
424 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
425 -- argument being passed to it. Ind indicates which formal of procedure
426 -- Proc we are trying to match. This function will, if necessary, generate
427 -- a conversion between the partial and full view of Arg to match the type
428 -- of the formal of Proc, or force a conversion to the class-wide type in
429 -- the case where the operation is abstract.
435 Skip_Self : Boolean := False) return Node_Id;
436 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
437 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
438 -- an adjust or finalization call. When flag Skip_Self is set, the related
439 -- action has an effect on the components only (if any).
441 function Make_Deep_Proc
442 (Prim : Final_Primitives;
444 Stmts : List_Id) return Entity_Id;
445 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
446 -- Deep_Finalize procedures according to the first parameter. These
447 -- procedures operate on the type Typ. The Stmts parameter gives the
448 -- body of the procedure.
450 function Make_Deep_Array_Body
451 (Prim : Final_Primitives;
452 Typ : Entity_Id) return List_Id;
453 -- This function generates the list of statements for implementing
454 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
455 -- the first parameter, these procedures operate on the array type Typ.
457 function Make_Deep_Record_Body
458 (Prim : Final_Primitives;
460 Is_Local : Boolean := False) return List_Id;
461 -- This function generates the list of statements for implementing
462 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
463 -- the first parameter, these procedures operate on the record type Typ.
464 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
465 -- whether the inner logic should be dictated by state counters.
467 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
468 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
469 -- Make_Deep_Record_Body. Generate the following statements:
472 -- type Acc_Typ is access all Typ;
473 -- for Acc_Typ'Storage_Size use 0;
475 -- [Deep_]Finalize (Acc_Typ (V).all);
478 --------------------------------
479 -- Allows_Finalization_Master --
480 --------------------------------
482 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
483 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
484 -- Determine whether entity E is inside a wrapper package created for
485 -- an instance of Ada.Unchecked_Deallocation.
487 ------------------------------
488 -- In_Deallocation_Instance --
489 ------------------------------
491 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
492 Pkg : constant Entity_Id := Scope (E);
493 Par : Node_Id := Empty;
496 if Ekind (Pkg) = E_Package
497 and then Present (Related_Instance (Pkg))
498 and then Ekind (Related_Instance (Pkg)) = E_Procedure
500 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
504 and then Chars (Par) = Name_Unchecked_Deallocation
505 and then Chars (Scope (Par)) = Name_Ada
506 and then Scope (Scope (Par)) = Standard_Standard;
510 end In_Deallocation_Instance;
514 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
515 Ptr_Typ : constant Entity_Id :=
516 Root_Type_Of_Full_View (Base_Type (Typ));
518 -- Start of processing for Allows_Finalization_Master
521 -- Certain run-time configurations and targets do not provide support
522 -- for controlled types and therefore do not need masters.
524 if Restriction_Active (No_Finalization) then
527 -- Do not consider C and C++ types since it is assumed that the non-Ada
528 -- side will handle their cleanup.
530 elsif Convention (Desig_Typ) = Convention_C
531 or else Convention (Desig_Typ) = Convention_CPP
535 -- Do not consider an access type that returns on the secondary stack
537 elsif Present (Associated_Storage_Pool (Ptr_Typ))
538 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
542 -- Do not consider an access type that can never allocate an object
544 elsif No_Pool_Assigned (Ptr_Typ) then
547 -- Do not consider an access type coming from an Unchecked_Deallocation
548 -- instance. Even though the designated type may be controlled, the
549 -- access type will never participate in any allocations.
551 elsif In_Deallocation_Instance (Ptr_Typ) then
554 -- Do not consider a non-library access type when No_Nested_Finalization
555 -- is in effect since finalization masters are controlled objects and if
556 -- created will violate the restriction.
558 elsif Restriction_Active (No_Nested_Finalization)
559 and then not Is_Library_Level_Entity (Ptr_Typ)
563 -- Do not consider an access type subject to pragma No_Heap_Finalization
564 -- because objects allocated through such a type are not to be finalized
565 -- when the access type goes out of scope.
567 elsif No_Heap_Finalization (Ptr_Typ) then
570 -- Do not create finalization masters in GNATprove mode because this
571 -- causes unwanted extra expansion. A compilation in this mode must
572 -- keep the tree as close as possible to the original sources.
574 elsif GNATprove_Mode then
577 -- Otherwise the access type may use a finalization master
582 end Allows_Finalization_Master;
584 ----------------------------
585 -- Build_Anonymous_Master --
586 ----------------------------
588 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
589 function Create_Anonymous_Master
590 (Desig_Typ : Entity_Id;
592 Unit_Decl : Node_Id) return Entity_Id;
593 -- Create a new anonymous master for access type Ptr_Typ with designated
594 -- type Desig_Typ. The declaration of the master and its initialization
595 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
596 -- the entity of Unit_Decl.
598 function Current_Anonymous_Master
599 (Desig_Typ : Entity_Id;
600 Unit_Id : Entity_Id) return Entity_Id;
601 -- Find an anonymous master declared within unit Unit_Id which services
602 -- designated type Desig_Typ. If there is no such master, return Empty.
604 -----------------------------
605 -- Create_Anonymous_Master --
606 -----------------------------
608 function Create_Anonymous_Master
609 (Desig_Typ : Entity_Id;
611 Unit_Decl : Node_Id) return Entity_Id
613 Loc : constant Source_Ptr := Sloc (Unit_Id);
624 -- <FM_Id> : Finalization_Master;
626 FM_Id := Make_Temporary (Loc, 'A');
629 Make_Object_Declaration (Loc,
630 Defining_Identifier => FM_Id,
632 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
636 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
639 Make_Procedure_Call_Statement (Loc,
641 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
642 Parameter_Associations => New_List (
643 New_Occurrence_Of (FM_Id, Loc),
644 Make_Attribute_Reference (Loc,
646 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
647 Attribute_Name => Name_Unrestricted_Access)));
649 -- Find the declarative list of the unit
651 if Nkind (Unit_Decl) = N_Package_Declaration then
652 Unit_Spec := Specification (Unit_Decl);
653 Decls := Visible_Declarations (Unit_Spec);
657 Set_Visible_Declarations (Unit_Spec, Decls);
660 -- Package body or subprogram case
662 -- ??? A subprogram spec or body that acts as a compilation unit may
663 -- contain a formal parameter of an anonymous access-to-controlled
664 -- type initialized by an allocator.
666 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
668 -- There is no suitable place to create the master as the subprogram
669 -- is not in a declarative list.
672 Decls := Declarations (Unit_Decl);
676 Set_Declarations (Unit_Decl, Decls);
680 Prepend_To (Decls, FM_Init);
681 Prepend_To (Decls, FM_Decl);
683 -- Use the scope of the unit when analyzing the declaration of the
684 -- master and its initialization actions.
686 Push_Scope (Unit_Id);
691 -- Mark the master as servicing this specific designated type
693 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
695 -- Include the anonymous master in the list of existing masters which
696 -- appear in this unit. This effectively creates a mapping between a
697 -- master and a designated type which in turn allows for the reuse of
698 -- masters on a per-unit basis.
700 All_FMs := Anonymous_Masters (Unit_Id);
703 All_FMs := New_Elmt_List;
704 Set_Anonymous_Masters (Unit_Id, All_FMs);
707 Prepend_Elmt (FM_Id, All_FMs);
710 end Create_Anonymous_Master;
712 ------------------------------
713 -- Current_Anonymous_Master --
714 ------------------------------
716 function Current_Anonymous_Master
717 (Desig_Typ : Entity_Id;
718 Unit_Id : Entity_Id) return Entity_Id
720 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
725 -- Inspect the list of anonymous masters declared within the unit
726 -- looking for an existing master which services the same designated
729 if Present (All_FMs) then
730 FM_Elmt := First_Elmt (All_FMs);
731 while Present (FM_Elmt) loop
732 FM_Id := Node (FM_Elmt);
734 -- The currect master services the same designated type. As a
735 -- result the master can be reused and associated with another
736 -- anonymous access-to-controlled type.
738 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
747 end Current_Anonymous_Master;
751 Desig_Typ : Entity_Id;
753 Priv_View : Entity_Id;
757 -- Start of processing for Build_Anonymous_Master
760 -- Nothing to do if the circumstances do not allow for a finalization
763 if not Allows_Finalization_Master (Ptr_Typ) then
767 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
768 Unit_Id := Unique_Defining_Entity (Unit_Decl);
770 -- The compilation unit is a package instantiation. In this case the
771 -- anonymous master is associated with the package spec as both the
772 -- spec and body appear at the same level.
774 if Nkind (Unit_Decl) = N_Package_Body
775 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
777 Unit_Id := Corresponding_Spec (Unit_Decl);
778 Unit_Decl := Unit_Declaration_Node (Unit_Id);
781 -- Use the initial declaration of the designated type when it denotes
782 -- the full view of an incomplete or private type. This ensures that
783 -- types with one and two views are treated the same.
785 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
786 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
788 if Present (Priv_View) then
789 Desig_Typ := Priv_View;
792 -- Determine whether the current semantic unit already has an anonymous
793 -- master which services the designated type.
795 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
797 -- If this is not the case, create a new master
800 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
803 Set_Finalization_Master (Ptr_Typ, FM_Id);
804 end Build_Anonymous_Master;
806 ----------------------------
807 -- Build_Array_Deep_Procs --
808 ----------------------------
810 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
814 (Prim => Initialize_Case,
816 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
818 if not Is_Limited_View (Typ) then
821 (Prim => Adjust_Case,
823 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
826 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
827 -- suppressed since these routine will not be used.
829 if not Restriction_Active (No_Finalization) then
832 (Prim => Finalize_Case,
834 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
836 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
838 if not CodePeer_Mode then
841 (Prim => Address_Case,
843 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
846 end Build_Array_Deep_Procs;
848 ------------------------------
849 -- Build_Cleanup_Statements --
850 ------------------------------
852 function Build_Cleanup_Statements
854 Additional_Cleanup : List_Id) return List_Id
856 Is_Asynchronous_Call : constant Boolean :=
857 Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N);
858 Is_Master : constant Boolean :=
859 Nkind (N) /= N_Entry_Body and then Is_Task_Master (N);
860 Is_Protected_Subp_Body : constant Boolean :=
861 Nkind (N) = N_Subprogram_Body
862 and then Is_Protected_Subprogram_Body (N);
863 Is_Task_Allocation : constant Boolean :=
864 Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N);
865 Is_Task_Body : constant Boolean :=
866 Nkind (Original_Node (N)) = N_Task_Body;
868 Loc : constant Source_Ptr := Sloc (N);
869 Stmts : constant List_Id := New_List;
873 if Restricted_Profile then
875 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
877 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
881 if Restriction_Active (No_Task_Hierarchy) = False then
882 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
885 -- Add statements to unlock the protected object parameter and to
886 -- undefer abort. If the context is a protected procedure and the object
887 -- has entries, call the entry service routine.
889 -- NOTE: The generated code references _object, a parameter to the
892 elsif Is_Protected_Subp_Body then
894 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
895 Conc_Typ : Entity_Id := Empty;
897 Param_Typ : Entity_Id;
900 -- Find the _object parameter representing the protected object
902 Param := First (Parameter_Specifications (Spec));
904 Param_Typ := Etype (Parameter_Type (Param));
906 if Ekind (Param_Typ) = E_Record_Type then
907 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
910 exit when No (Param) or else Present (Conc_Typ);
914 pragma Assert (Present (Param));
915 pragma Assert (Present (Conc_Typ));
917 Build_Protected_Subprogram_Call_Cleanup
918 (Specification (N), Conc_Typ, Loc, Stmts);
921 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
922 -- tasks. Other unactivated tasks are completed by Complete_Task or
925 -- NOTE: The generated code references _chain, a local object
927 elsif Is_Task_Allocation then
930 -- Expunge_Unactivated_Tasks (_chain);
932 -- where _chain is the list of tasks created by the allocator but not
933 -- yet activated. This list will be empty unless the block completes
937 Make_Procedure_Call_Statement (Loc,
940 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
941 Parameter_Associations => New_List (
942 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
944 -- Attempt to cancel an asynchronous entry call whenever the block which
945 -- contains the abortable part is exited.
947 -- NOTE: The generated code references Cnn, a local object
949 elsif Is_Asynchronous_Call then
951 Cancel_Param : constant Entity_Id :=
952 Entry_Cancel_Parameter (Entity (Identifier (N)));
955 -- If it is of type Communication_Block, this must be a protected
956 -- entry call. Generate:
958 -- if Enqueued (Cancel_Param) then
959 -- Cancel_Protected_Entry_Call (Cancel_Param);
962 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
964 Make_If_Statement (Loc,
966 Make_Function_Call (Loc,
968 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
969 Parameter_Associations => New_List (
970 New_Occurrence_Of (Cancel_Param, Loc))),
972 Then_Statements => New_List (
973 Make_Procedure_Call_Statement (Loc,
976 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
977 Parameter_Associations => New_List (
978 New_Occurrence_Of (Cancel_Param, Loc))))));
980 -- Asynchronous delay, generate:
981 -- Cancel_Async_Delay (Cancel_Param);
983 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
985 Make_Procedure_Call_Statement (Loc,
987 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
988 Parameter_Associations => New_List (
989 Make_Attribute_Reference (Loc,
991 New_Occurrence_Of (Cancel_Param, Loc),
992 Attribute_Name => Name_Unchecked_Access))));
994 -- Task entry call, generate:
995 -- Cancel_Task_Entry_Call (Cancel_Param);
999 Make_Procedure_Call_Statement (Loc,
1001 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
1002 Parameter_Associations => New_List (
1003 New_Occurrence_Of (Cancel_Param, Loc))));
1008 Append_List_To (Stmts, Additional_Cleanup);
1010 end Build_Cleanup_Statements;
1012 -----------------------------
1013 -- Build_Controlling_Procs --
1014 -----------------------------
1016 procedure Build_Controlling_Procs (Typ : Entity_Id) is
1018 if Is_Array_Type (Typ) then
1019 Build_Array_Deep_Procs (Typ);
1020 else pragma Assert (Is_Record_Type (Typ));
1021 Build_Record_Deep_Procs (Typ);
1023 end Build_Controlling_Procs;
1025 -----------------------------
1026 -- Build_Exception_Handler --
1027 -----------------------------
1029 function Build_Exception_Handler
1030 (Data : Finalization_Exception_Data;
1031 For_Library : Boolean := False) return Node_Id
1034 Proc_To_Call : Entity_Id;
1039 pragma Assert (Present (Data.Raised_Id));
1041 if Exception_Extra_Info
1042 or else (For_Library and not Restricted_Profile)
1044 if Exception_Extra_Info then
1048 -- Get_Current_Excep.all
1051 Make_Function_Call (Data.Loc,
1053 Make_Explicit_Dereference (Data.Loc,
1056 (RTE (RE_Get_Current_Excep), Data.Loc)));
1063 Except := Make_Null (Data.Loc);
1066 if For_Library and then not Restricted_Profile then
1067 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1068 Actuals := New_List (Except);
1071 Proc_To_Call := RTE (RE_Save_Occurrence);
1073 -- The dereference occurs only when Exception_Extra_Info is true,
1074 -- and therefore Except is not null.
1078 New_Occurrence_Of (Data.E_Id, Data.Loc),
1079 Make_Explicit_Dereference (Data.Loc, Except));
1085 -- if not Raised_Id then
1086 -- Raised_Id := True;
1088 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1090 -- Save_Library_Occurrence (Get_Current_Excep.all);
1095 Make_If_Statement (Data.Loc,
1097 Make_Op_Not (Data.Loc,
1098 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1100 Then_Statements => New_List (
1101 Make_Assignment_Statement (Data.Loc,
1102 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1103 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1105 Make_Procedure_Call_Statement (Data.Loc,
1107 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1108 Parameter_Associations => Actuals))));
1113 -- Raised_Id := True;
1116 Make_Assignment_Statement (Data.Loc,
1117 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1118 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1126 Make_Exception_Handler (Data.Loc,
1127 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1128 Statements => Stmts);
1129 end Build_Exception_Handler;
1131 -------------------------------
1132 -- Build_Finalization_Master --
1133 -------------------------------
1135 procedure Build_Finalization_Master
1137 For_Lib_Level : Boolean := False;
1138 For_Private : Boolean := False;
1139 Context_Scope : Entity_Id := Empty;
1140 Insertion_Node : Node_Id := Empty)
1142 procedure Add_Pending_Access_Type
1144 Ptr_Typ : Entity_Id);
1145 -- Add access type Ptr_Typ to the pending access type list for type Typ
1147 -----------------------------
1148 -- Add_Pending_Access_Type --
1149 -----------------------------
1151 procedure Add_Pending_Access_Type
1153 Ptr_Typ : Entity_Id)
1158 if Present (Pending_Access_Types (Typ)) then
1159 List := Pending_Access_Types (Typ);
1161 List := New_Elmt_List;
1162 Set_Pending_Access_Types (Typ, List);
1165 Prepend_Elmt (Ptr_Typ, List);
1166 end Add_Pending_Access_Type;
1170 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1172 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1173 -- A finalization master created for a named access type is associated
1174 -- with the full view (if applicable) as a consequence of freezing. The
1175 -- full view criteria does not apply to anonymous access types because
1176 -- those cannot have a private and a full view.
1178 -- Start of processing for Build_Finalization_Master
1181 -- Nothing to do if the circumstances do not allow for a finalization
1184 if not Allows_Finalization_Master (Typ) then
1187 -- Various machinery such as freezing may have already created a
1188 -- finalization master.
1190 elsif Present (Finalization_Master (Ptr_Typ)) then
1195 Actions : constant List_Id := New_List;
1196 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1197 Fin_Mas_Id : Entity_Id;
1198 Pool_Id : Entity_Id;
1201 -- Source access types use fixed master names since the master is
1202 -- inserted in the same source unit only once. The only exception to
1203 -- this are instances using the same access type as generic actual.
1205 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1207 Make_Defining_Identifier (Loc,
1208 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
1210 -- Internally generated access types use temporaries as their names
1211 -- due to possible collision with identical names coming from other
1215 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1218 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1221 -- <Ptr_Typ>FM : aliased Finalization_Master;
1224 Make_Object_Declaration (Loc,
1225 Defining_Identifier => Fin_Mas_Id,
1226 Aliased_Present => True,
1227 Object_Definition =>
1228 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
1230 if Debug_Generated_Code then
1231 Set_Debug_Info_Needed (Fin_Mas_Id);
1234 -- Set the associated pool and primitive Finalize_Address of the new
1235 -- finalization master.
1237 -- The access type has a user-defined storage pool, use it
1239 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1240 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1242 -- Otherwise the default choice is the global storage pool
1245 Pool_Id := RTE (RE_Global_Pool_Object);
1246 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1250 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1253 Make_Procedure_Call_Statement (Loc,
1255 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
1256 Parameter_Associations => New_List (
1257 New_Occurrence_Of (Fin_Mas_Id, Loc),
1258 Make_Attribute_Reference (Loc,
1259 Prefix => New_Occurrence_Of (Pool_Id, Loc),
1260 Attribute_Name => Name_Unrestricted_Access))));
1262 -- Finalize_Address is not generated in CodePeer mode because the
1263 -- body contains address arithmetic. Skip this step.
1265 if CodePeer_Mode then
1268 -- Associate the Finalize_Address primitive of the designated type
1269 -- with the finalization master of the access type. The designated
1270 -- type must be forzen as Finalize_Address is generated when the
1271 -- freeze node is expanded.
1273 elsif Is_Frozen (Desig_Typ)
1274 and then Present (Finalize_Address (Desig_Typ))
1276 -- The finalization master of an anonymous access type may need
1277 -- to be inserted in a specific place in the tree. For instance:
1281 -- <finalization master of "access Comp_Typ">
1283 -- type Rec_Typ is record
1284 -- Comp : access Comp_Typ;
1287 -- <freeze node for Comp_Typ>
1288 -- <freeze node for Rec_Typ>
1290 -- Due to this oddity, the anonymous access type is stored for
1291 -- later processing (see below).
1293 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
1296 -- Set_Finalize_Address
1297 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1300 Make_Set_Finalize_Address_Call
1302 Ptr_Typ => Ptr_Typ));
1304 -- Otherwise the designated type is either anonymous access or a
1305 -- Taft-amendment type and has not been frozen. Store the access
1306 -- type for later processing (see Freeze_Type).
1309 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1312 -- A finalization master created for an access designating a type
1313 -- with private components is inserted before a context-dependent
1318 -- At this point both the scope of the context and the insertion
1319 -- mode must be known.
1321 pragma Assert (Present (Context_Scope));
1322 pragma Assert (Present (Insertion_Node));
1324 Push_Scope (Context_Scope);
1326 -- Treat use clauses as declarations and insert directly in front
1329 if Nkind (Insertion_Node) in
1330 N_Use_Package_Clause | N_Use_Type_Clause
1332 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1334 Insert_Actions (Insertion_Node, Actions);
1339 -- The finalization master belongs to an access result type related
1340 -- to a build-in-place function call used to initialize a library
1341 -- level object. The master must be inserted in front of the access
1342 -- result type declaration denoted by Insertion_Node.
1344 elsif For_Lib_Level then
1345 pragma Assert (Present (Insertion_Node));
1346 Insert_Actions (Insertion_Node, Actions);
1348 -- Otherwise the finalization master and its initialization become a
1349 -- part of the freeze node.
1352 Append_Freeze_Actions (Ptr_Typ, Actions);
1355 Analyze_List (Actions);
1357 -- When the type the finalization master is being generated for was
1358 -- created to store a 'Old object, then mark it as such so its
1359 -- finalization can be delayed until after postconditions have been
1362 if Stores_Attribute_Old_Prefix (Ptr_Typ) then
1363 Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id);
1366 end Build_Finalization_Master;
1368 ---------------------
1369 -- Build_Finalizer --
1370 ---------------------
1372 procedure Build_Finalizer
1374 Clean_Stmts : List_Id;
1375 Mark_Id : Entity_Id;
1376 Top_Decls : List_Id;
1377 Defer_Abort : Boolean;
1378 Fin_Id : out Entity_Id)
1380 Acts_As_Clean : constant Boolean :=
1383 (Present (Clean_Stmts)
1384 and then Is_Non_Empty_List (Clean_Stmts));
1386 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1387 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1388 For_Package : constant Boolean :=
1389 For_Package_Body or else For_Package_Spec;
1390 Loc : constant Source_Ptr := Sloc (N);
1392 -- NOTE: Local variable declarations are conservative and do not create
1393 -- structures right from the start. Entities and lists are created once
1394 -- it has been established that N has at least one controlled object.
1396 Components_Built : Boolean := False;
1397 -- A flag used to avoid double initialization of entities and lists. If
1398 -- the flag is set then the following variables have been initialized:
1404 Counter_Id : Entity_Id := Empty;
1405 Counter_Val : Nat := 0;
1406 -- Name and value of the state counter
1408 Decls : List_Id := No_List;
1409 -- Declarative region of N (if available). If N is a package declaration
1410 -- Decls denotes the visible declarations.
1412 Finalizer_Data : Finalization_Exception_Data;
1413 -- Data for the exception
1415 Finalizer_Decls : List_Id := No_List;
1416 -- Local variable declarations. This list holds the label declarations
1417 -- of all jump block alternatives as well as the declaration of the
1418 -- local exception occurrence and the raised flag:
1419 -- E : Exception_Occurrence;
1420 -- Raised : Boolean := False;
1421 -- L<counter value> : label;
1423 Finalizer_Insert_Nod : Node_Id := Empty;
1424 -- Insertion point for the finalizer body. Depending on the context
1425 -- (Nkind of N) and the individual grouping of controlled objects, this
1426 -- node may denote a package declaration or body, package instantiation,
1427 -- block statement or a counter update statement.
1429 Finalizer_Stmts : List_Id := No_List;
1430 -- The statement list of the finalizer body. It contains the following:
1432 -- Abort_Defer; -- Added if abort is allowed
1433 -- <call to Prev_At_End> -- Added if exists
1434 -- <cleanup statements> -- Added if Acts_As_Clean
1435 -- <jump block> -- Added if Has_Ctrl_Objs
1436 -- <finalization statements> -- Added if Has_Ctrl_Objs
1437 -- <stack release> -- Added if Mark_Id exists
1438 -- Abort_Undefer; -- Added if abort is allowed
1440 Has_Ctrl_Objs : Boolean := False;
1441 -- A general flag which denotes whether N has at least one controlled
1444 Has_Tagged_Types : Boolean := False;
1445 -- A general flag which indicates whether N has at least one library-
1446 -- level tagged type declaration.
1448 HSS : Node_Id := Empty;
1449 -- The sequence of statements of N (if available)
1451 Jump_Alts : List_Id := No_List;
1452 -- Jump block alternatives. Depending on the value of the state counter,
1453 -- the control flow jumps to a sequence of finalization statements. This
1454 -- list contains the following:
1456 -- when <counter value> =>
1457 -- goto L<counter value>;
1459 Jump_Block_Insert_Nod : Node_Id := Empty;
1460 -- Specific point in the finalizer statements where the jump block is
1463 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1464 -- The last controlled construct encountered when processing the top
1465 -- level lists of N. This can be a nested package, an instantiation or
1466 -- an object declaration.
1468 Prev_At_End : Entity_Id := Empty;
1469 -- The previous at end procedure of the handled statements block of N
1471 Priv_Decls : List_Id := No_List;
1472 -- The private declarations of N if N is a package declaration
1474 Spec_Id : Entity_Id := Empty;
1475 Spec_Decls : List_Id := Top_Decls;
1476 Stmts : List_Id := No_List;
1478 Tagged_Type_Stmts : List_Id := No_List;
1479 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1480 -- tagged types found in N.
1482 -----------------------
1483 -- Local subprograms --
1484 -----------------------
1486 procedure Build_Components;
1487 -- Create all entites and initialize all lists used in the creation of
1490 procedure Create_Finalizer;
1491 -- Create the spec and body of the finalizer and insert them in the
1492 -- proper place in the tree depending on the context.
1494 function New_Finalizer_Name
1495 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id;
1496 -- Create a fully qualified name of a package spec or body finalizer.
1497 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1499 procedure Process_Declarations
1501 Preprocess : Boolean := False;
1502 Top_Level : Boolean := False);
1503 -- Inspect a list of declarations or statements which may contain
1504 -- objects that need finalization. When flag Preprocess is set, the
1505 -- routine will simply count the total number of controlled objects in
1506 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1507 -- when Preprocess is set and if True, the processing is performed for
1508 -- objects in nested package declarations or instances.
1510 procedure Process_Object_Declaration
1512 Has_No_Init : Boolean := False;
1513 Is_Protected : Boolean := False);
1514 -- Generate all the machinery associated with the finalization of a
1515 -- single object. Flag Has_No_Init is used to denote certain contexts
1516 -- where Decl does not have initialization call(s). Flag Is_Protected
1517 -- is set when Decl denotes a simple protected object.
1519 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1520 -- Generate all the code necessary to unregister the external tag of a
1523 ----------------------
1524 -- Build_Components --
1525 ----------------------
1527 procedure Build_Components is
1528 Counter_Decl : Node_Id;
1529 Counter_Typ : Entity_Id;
1530 Counter_Typ_Decl : Node_Id;
1533 pragma Assert (Present (Decls));
1535 -- This routine might be invoked several times when dealing with
1536 -- constructs that have two lists (either two declarative regions
1537 -- or declarations and statements). Avoid double initialization.
1539 if Components_Built then
1543 Components_Built := True;
1545 if Has_Ctrl_Objs then
1547 -- Create entities for the counter, its type, the local exception
1548 -- and the raised flag.
1550 Counter_Id := Make_Temporary (Loc, 'C');
1551 Counter_Typ := Make_Temporary (Loc, 'T');
1553 Finalizer_Decls := New_List;
1555 Build_Object_Declarations
1556 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1558 -- Since the total number of controlled objects is always known,
1559 -- build a subtype of Natural with precise bounds. This allows
1560 -- the backend to optimize the case statement. Generate:
1562 -- subtype Tnn is Natural range 0 .. Counter_Val;
1565 Make_Subtype_Declaration (Loc,
1566 Defining_Identifier => Counter_Typ,
1567 Subtype_Indication =>
1568 Make_Subtype_Indication (Loc,
1569 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1571 Make_Range_Constraint (Loc,
1575 Make_Integer_Literal (Loc, Uint_0),
1577 Make_Integer_Literal (Loc, Counter_Val)))));
1579 -- Generate the declaration of the counter itself:
1581 -- Counter : Integer := 0;
1584 Make_Object_Declaration (Loc,
1585 Defining_Identifier => Counter_Id,
1586 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1587 Expression => Make_Integer_Literal (Loc, 0));
1589 -- Set the type of the counter explicitly to prevent errors when
1590 -- examining object declarations later on.
1592 Set_Etype (Counter_Id, Counter_Typ);
1594 if Debug_Generated_Code then
1595 Set_Debug_Info_Needed (Counter_Id);
1598 -- The counter and its type are inserted before the source
1599 -- declarations of N.
1601 Prepend_To (Decls, Counter_Decl);
1602 Prepend_To (Decls, Counter_Typ_Decl);
1604 -- The counter and its associated type must be manually analyzed
1605 -- since N has already been analyzed. Use the scope of the spec
1606 -- when inserting in a package.
1609 Push_Scope (Spec_Id);
1610 Analyze (Counter_Typ_Decl);
1611 Analyze (Counter_Decl);
1615 Analyze (Counter_Typ_Decl);
1616 Analyze (Counter_Decl);
1619 Jump_Alts := New_List;
1622 -- If the context requires additional cleanup, the finalization
1623 -- machinery is added after the cleanup code.
1625 if Acts_As_Clean then
1626 Finalizer_Stmts := Clean_Stmts;
1627 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1629 Finalizer_Stmts := New_List;
1632 if Has_Tagged_Types then
1633 Tagged_Type_Stmts := New_List;
1635 end Build_Components;
1637 ----------------------
1638 -- Create_Finalizer --
1639 ----------------------
1641 procedure Create_Finalizer is
1642 Body_Id : Entity_Id;
1645 Jump_Block : Node_Id;
1647 Label_Id : Entity_Id;
1650 -- Step 1: Creation of the finalizer name
1652 -- Packages must use a distinct name for their finalizers since the
1653 -- binder will have to generate calls to them by name. The name is
1654 -- of the following form:
1656 -- xx__yy__finalize_[spec|body]
1659 Fin_Id := Make_Defining_Identifier
1660 (Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec));
1661 Set_Has_Qualified_Name (Fin_Id);
1662 Set_Has_Fully_Qualified_Name (Fin_Id);
1664 -- The default name is _finalizer
1667 -- Generation of a finalization procedure exclusively for 'Old
1668 -- interally generated constants requires different name since
1669 -- there will need to be multiple finalization routines in the
1670 -- same scope. See Build_Finalizer for details.
1673 Make_Defining_Identifier (Loc,
1674 Chars => New_External_Name (Name_uFinalizer));
1676 -- The visibility semantics of AT_END handlers force a strange
1677 -- separation of spec and body for stack-related finalizers:
1679 -- declare : Enclosing_Scope
1680 -- procedure _finalizer;
1682 -- <controlled objects>
1683 -- procedure _finalizer is
1689 -- Both spec and body are within the same construct and scope, but
1690 -- the body is part of the handled sequence of statements. This
1691 -- placement confuses the elaboration mechanism on targets where
1692 -- AT_END handlers are expanded into "when all others" handlers:
1695 -- when all others =>
1696 -- _finalizer; -- appears to require elab checks
1701 -- Since the compiler guarantees that the body of a _finalizer is
1702 -- always inserted in the same construct where the AT_END handler
1703 -- resides, there is no need for elaboration checks.
1705 Set_Kill_Elaboration_Checks (Fin_Id);
1707 -- Inlining the finalizer produces a substantial speedup at -O2.
1708 -- It is inlined by default at -O3. Either way, it is called
1709 -- exactly twice (once on the normal path, and once for
1710 -- exceptions/abort), so this won't bloat the code too much.
1712 Set_Is_Inlined (Fin_Id);
1715 if Debug_Generated_Code then
1716 Set_Debug_Info_Needed (Fin_Id);
1719 -- Step 2: Creation of the finalizer specification
1722 -- procedure Fin_Id;
1725 Make_Subprogram_Declaration (Loc,
1727 Make_Procedure_Specification (Loc,
1728 Defining_Unit_Name => Fin_Id));
1731 Set_Is_Exported (Fin_Id);
1732 Set_Interface_Name (Fin_Id,
1733 Make_String_Literal (Loc,
1734 Strval => Get_Name_String (Chars (Fin_Id))));
1737 -- Step 3: Creation of the finalizer body
1739 -- Has_Ctrl_Objs might be set because of a generic package body having
1740 -- controlled objects. In this case, Jump_Alts may be empty and no
1741 -- case nor goto statements are needed.
1744 and then not Is_Empty_List (Jump_Alts)
1746 -- Add L0, the default destination to the jump block
1748 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1749 Set_Entity (Label_Id,
1750 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1751 Label := Make_Label (Loc, Label_Id);
1756 Prepend_To (Finalizer_Decls,
1757 Make_Implicit_Label_Declaration (Loc,
1758 Defining_Identifier => Entity (Label_Id),
1759 Label_Construct => Label));
1765 Append_To (Jump_Alts,
1766 Make_Case_Statement_Alternative (Loc,
1767 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1768 Statements => New_List (
1769 Make_Goto_Statement (Loc,
1770 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1775 Append_To (Finalizer_Stmts, Label);
1777 -- Create the jump block which controls the finalization flow
1778 -- depending on the value of the state counter.
1781 Make_Case_Statement (Loc,
1782 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1783 Alternatives => Jump_Alts);
1785 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1786 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1788 Prepend_To (Finalizer_Stmts, Jump_Block);
1792 -- Add the library-level tagged type unregistration machinery before
1793 -- the jump block circuitry. This ensures that external tags will be
1794 -- removed even if a finalization exception occurs at some point.
1796 if Has_Tagged_Types then
1797 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1800 -- Add a call to the previous At_End handler if it exists. The call
1801 -- must always precede the jump block.
1803 if Present (Prev_At_End) then
1804 Prepend_To (Finalizer_Stmts,
1805 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1807 -- Clear the At_End handler since we have already generated the
1808 -- proper replacement call for it.
1810 Set_At_End_Proc (HSS, Empty);
1813 -- Release the secondary stack
1815 if Present (Mark_Id) then
1817 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
1820 -- If the context is a build-in-place function, the secondary
1821 -- stack must be released, unless the build-in-place function
1822 -- itself is returning on the secondary stack. Generate:
1824 -- if BIP_Alloc_Form /= Secondary_Stack then
1825 -- SS_Release (Mark_Id);
1828 -- Note that if the function returns on the secondary stack,
1829 -- then the responsibility of reclaiming the space is always
1830 -- left to the caller (recursively if needed).
1832 if Nkind (N) = N_Subprogram_Body then
1834 Spec_Id : constant Entity_Id :=
1835 Unique_Defining_Entity (N);
1836 BIP_SS : constant Boolean :=
1837 Is_Build_In_Place_Function (Spec_Id)
1838 and then Needs_BIP_Alloc_Form (Spec_Id);
1842 Make_If_Statement (Loc,
1847 (Build_In_Place_Formal
1848 (Spec_Id, BIP_Alloc_Form), Loc),
1850 Make_Integer_Literal (Loc,
1852 (BIP_Allocation_Form'Pos
1853 (Secondary_Stack)))),
1855 Then_Statements => New_List (Release));
1860 Append_To (Finalizer_Stmts, Release);
1864 -- Protect the statements with abort defer/undefer. This is only when
1865 -- aborts are allowed and the cleanup statements require deferral or
1866 -- there are controlled objects to be finalized. Note that the abort
1867 -- defer/undefer pair does not require an extra block because each
1868 -- finalization exception is caught in its corresponding finalization
1869 -- block. As a result, the call to Abort_Defer always takes place.
1871 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1872 Prepend_To (Finalizer_Stmts,
1873 Build_Runtime_Call (Loc, RE_Abort_Defer));
1875 Append_To (Finalizer_Stmts,
1876 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1879 -- The local exception does not need to be reraised for library-level
1880 -- finalizers. Note that this action must be carried out after object
1881 -- cleanup, secondary stack release, and abort undeferral. Generate:
1883 -- if Raised and then not Abort then
1884 -- Raise_From_Controlled_Operation (E);
1887 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1888 Append_To (Finalizer_Stmts,
1889 Build_Raise_Statement (Finalizer_Data));
1893 -- procedure Fin_Id is
1894 -- Abort : constant Boolean := Triggered_By_Abort;
1896 -- Abort : constant Boolean := False; -- no abort
1898 -- E : Exception_Occurrence; -- All added if flag
1899 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1905 -- Abort_Defer; -- Added if abort is allowed
1906 -- <call to Prev_At_End> -- Added if exists
1907 -- <cleanup statements> -- Added if Acts_As_Clean
1908 -- <jump block> -- Added if Has_Ctrl_Objs
1909 -- <finalization statements> -- Added if Has_Ctrl_Objs
1910 -- <stack release> -- Added if Mark_Id exists
1911 -- Abort_Undefer; -- Added if abort is allowed
1912 -- <exception propagation> -- Added if Has_Ctrl_Objs
1915 -- Create the body of the finalizer
1917 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1919 if Debug_Generated_Code then
1920 Set_Debug_Info_Needed (Body_Id);
1924 Set_Has_Qualified_Name (Body_Id);
1925 Set_Has_Fully_Qualified_Name (Body_Id);
1929 Make_Subprogram_Body (Loc,
1931 Make_Procedure_Specification (Loc,
1932 Defining_Unit_Name => Body_Id),
1933 Declarations => Finalizer_Decls,
1934 Handled_Statement_Sequence =>
1935 Make_Handled_Sequence_Of_Statements (Loc,
1936 Statements => Finalizer_Stmts));
1938 -- Step 4: Spec and body insertion, analysis
1942 -- If the package spec has private declarations, the finalizer
1943 -- body must be added to the end of the list in order to have
1944 -- visibility of all private controlled objects.
1946 if For_Package_Spec then
1947 if Present (Priv_Decls) then
1948 Append_To (Priv_Decls, Fin_Spec);
1949 Append_To (Priv_Decls, Fin_Body);
1951 Append_To (Decls, Fin_Spec);
1952 Append_To (Decls, Fin_Body);
1955 -- For package bodies, both the finalizer spec and body are
1956 -- inserted at the end of the package declarations.
1959 Append_To (Decls, Fin_Spec);
1960 Append_To (Decls, Fin_Body);
1963 -- Push the name of the package
1965 Push_Scope (Spec_Id);
1973 -- Create the spec for the finalizer. The At_End handler must be
1974 -- able to call the body which resides in a nested structure.
1978 -- procedure Fin_Id; -- Spec
1980 -- <objects and possibly statements>
1981 -- procedure Fin_Id is ... -- Body
1984 -- Fin_Id; -- At_End handler
1987 pragma Assert (Present (Spec_Decls));
1989 -- It maybe possible that we are finalizing 'Old objects which
1990 -- exist in the spec declarations. When this is the case the
1991 -- Finalizer_Insert_Node will come before the end of the
1992 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1993 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1994 -- end of Spec_Decls to prevent its body appearing before its
1995 -- corresponding spec.
1997 if Present (Finalizer_Insert_Nod)
1998 and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls
2000 Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec);
2001 Finalizer_Insert_Nod := Fin_Spec;
2003 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
2006 Append_To (Spec_Decls, Fin_Spec);
2010 -- When the finalizer acts solely as a cleanup routine, the body
2011 -- is inserted right after the spec.
2013 if Acts_As_Clean and not Has_Ctrl_Objs then
2014 Insert_After (Fin_Spec, Fin_Body);
2016 -- In all other cases the body is inserted after either:
2018 -- 1) The counter update statement of the last controlled object
2019 -- 2) The last top level nested controlled package
2020 -- 3) The last top level controlled instantiation
2023 -- Manually freeze the spec. This is somewhat of a hack because
2024 -- a subprogram is frozen when its body is seen and the freeze
2025 -- node appears right before the body. However, in this case,
2026 -- the spec must be frozen earlier since the At_End handler
2027 -- must be able to call it.
2030 -- procedure Fin_Id; -- Spec
2031 -- [Fin_Id] -- Freeze node
2035 -- Fin_Id; -- At_End handler
2038 Ensure_Freeze_Node (Fin_Id);
2039 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
2040 Set_Is_Frozen (Fin_Id);
2042 -- In the case where the last construct to contain a controlled
2043 -- object is either a nested package, an instantiation or a
2044 -- freeze node, the body must be inserted directly after the
2045 -- construct, except if the insertion point is already placed
2046 -- after the construct, typically in the statement list.
2048 if Nkind (Last_Top_Level_Ctrl_Construct) in
2049 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2051 (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls
2052 and then Present (Stmts)
2053 and then List_Containing (Finalizer_Insert_Nod) = Stmts)
2055 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
2058 Insert_After (Finalizer_Insert_Nod, Fin_Body);
2061 Analyze (Fin_Body, Suppress => All_Checks);
2064 -- Never consider that the finalizer procedure is enabled Ghost, even
2065 -- when the corresponding unit is Ghost, as this would lead to an
2066 -- an external name with a ___ghost_ prefix that the binder cannot
2067 -- generate, as it has no knowledge of the Ghost status of units.
2069 Set_Is_Checked_Ghost_Entity (Fin_Id, False);
2070 end Create_Finalizer;
2072 ------------------------
2073 -- New_Finalizer_Name --
2074 ------------------------
2076 function New_Finalizer_Name
2077 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id
2079 procedure New_Finalizer_Name (Id : Entity_Id);
2080 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2081 -- has a non-standard scope, process the scope first.
2083 ------------------------
2084 -- New_Finalizer_Name --
2085 ------------------------
2087 procedure New_Finalizer_Name (Id : Entity_Id) is
2089 if Scope (Id) = Standard_Standard then
2090 Get_Name_String (Chars (Id));
2093 New_Finalizer_Name (Scope (Id));
2094 Add_Str_To_Name_Buffer ("__");
2095 Get_Name_String_And_Append (Chars (Id));
2097 end New_Finalizer_Name;
2099 -- Start of processing for New_Finalizer_Name
2102 -- Create the fully qualified name of the enclosing scope
2104 New_Finalizer_Name (Spec_Id);
2107 -- __finalize_[spec|body]
2109 Add_Str_To_Name_Buffer ("__finalize_");
2112 Add_Str_To_Name_Buffer ("spec");
2114 Add_Str_To_Name_Buffer ("body");
2118 end New_Finalizer_Name;
2120 --------------------------
2121 -- Process_Declarations --
2122 --------------------------
2124 procedure Process_Declarations
2126 Preprocess : Boolean := False;
2127 Top_Level : Boolean := False)
2132 Obj_Typ : Entity_Id;
2133 Pack_Id : Entity_Id;
2137 Old_Counter_Val : Nat;
2138 -- This variable is used to determine whether a nested package or
2139 -- instance contains at least one controlled object.
2141 procedure Processing_Actions
2142 (Has_No_Init : Boolean := False;
2143 Is_Protected : Boolean := False);
2144 -- Depending on the mode of operation of Process_Declarations, either
2145 -- increment the controlled object counter, set the controlled object
2146 -- flag and store the last top level construct or process the current
2147 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2148 -- the current declaration may not have initialization proc(s). Flag
2149 -- Is_Protected should be set when the current declaration denotes a
2150 -- simple protected object.
2152 ------------------------
2153 -- Processing_Actions --
2154 ------------------------
2156 procedure Processing_Actions
2157 (Has_No_Init : Boolean := False;
2158 Is_Protected : Boolean := False)
2161 -- Library-level tagged type
2163 if Nkind (Decl) = N_Full_Type_Declaration then
2165 Has_Tagged_Types := True;
2167 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2168 Last_Top_Level_Ctrl_Construct := Decl;
2171 -- Unregister tagged type, unless No_Tagged_Type_Registration
2174 elsif not Restriction_Active (No_Tagged_Type_Registration) then
2175 Process_Tagged_Type_Declaration (Decl);
2178 -- Controlled object declaration
2182 Counter_Val := Counter_Val + 1;
2183 Has_Ctrl_Objs := True;
2185 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2186 Last_Top_Level_Ctrl_Construct := Decl;
2190 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2193 end Processing_Actions;
2195 -- Start of processing for Process_Declarations
2198 if Is_Empty_List (Decls) then
2202 -- Process all declarations in reverse order
2204 Decl := Last_Non_Pragma (Decls);
2205 while Present (Decl) loop
2206 -- Library-level tagged types
2208 if Nkind (Decl) = N_Full_Type_Declaration then
2209 Typ := Defining_Identifier (Decl);
2211 -- Ignored Ghost types do not need any cleanup actions because
2212 -- they will not appear in the final tree.
2214 if Is_Ignored_Ghost_Entity (Typ) then
2217 elsif Is_Tagged_Type (Typ)
2218 and then Is_Library_Level_Entity (Typ)
2219 and then Convention (Typ) = Convention_Ada
2220 and then Present (Access_Disp_Table (Typ))
2221 and then not Is_Abstract_Type (Typ)
2222 and then not No_Run_Time_Mode
2223 and then not Restriction_Active (No_Tagged_Type_Registration)
2224 and then RTE_Available (RE_Register_Tag)
2229 -- Regular object declarations
2231 elsif Nkind (Decl) = N_Object_Declaration then
2232 Obj_Id := Defining_Identifier (Decl);
2233 Obj_Typ := Base_Type (Etype (Obj_Id));
2234 Expr := Expression (Decl);
2236 -- Bypass any form of processing for objects which have their
2237 -- finalization disabled. This applies only to objects at the
2240 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2243 -- Finalization of transient objects are treated separately in
2244 -- order to handle sensitive cases. These include:
2246 -- * Aggregate expansion
2247 -- * If, case, and expression with actions expansion
2248 -- * Transient scopes
2250 -- If one of those contexts has marked the transient object as
2251 -- ignored, do not generate finalization actions for it.
2253 elsif Is_Finalized_Transient (Obj_Id)
2254 or else Is_Ignored_Transient (Obj_Id)
2258 -- Ignored Ghost objects do not need any cleanup actions
2259 -- because they will not appear in the final tree.
2261 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2264 -- The object is of the form:
2265 -- Obj : [constant] Typ [:= Expr];
2267 -- Do not process tag-to-class-wide conversions because they do
2268 -- not yield an object. Do not process the incomplete view of a
2269 -- deferred constant. Note that an object initialized by means
2270 -- of a build-in-place function call may appear as a deferred
2271 -- constant after expansion activities. These kinds of objects
2272 -- must be finalized.
2274 elsif not Is_Imported (Obj_Id)
2275 and then Needs_Finalization (Obj_Typ)
2276 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
2277 and then not (Ekind (Obj_Id) = E_Constant
2278 and then not Has_Completion (Obj_Id)
2279 and then No (BIP_Initialization_Call (Obj_Id)))
2283 -- The object is of the form:
2284 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2286 -- Obj : Access_Typ :=
2287 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2289 elsif Is_Access_Type (Obj_Typ)
2290 and then Needs_Finalization
2291 (Available_View (Designated_Type (Obj_Typ)))
2292 and then Present (Expr)
2294 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2296 (Is_Non_BIP_Func_Call (Expr)
2297 and then not Is_Related_To_Func_Return (Obj_Id)))
2299 Processing_Actions (Has_No_Init => True);
2301 -- Processing for "hook" objects generated for transient
2302 -- objects declared inside an Expression_With_Actions.
2304 elsif Is_Access_Type (Obj_Typ)
2305 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2306 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2307 N_Object_Declaration
2309 Processing_Actions (Has_No_Init => True);
2311 -- Process intermediate results of an if expression with one
2312 -- of the alternatives using a controlled function call.
2314 elsif Is_Access_Type (Obj_Typ)
2315 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2316 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2317 N_Defining_Identifier
2318 and then Present (Expr)
2319 and then Nkind (Expr) = N_Null
2321 Processing_Actions (Has_No_Init => True);
2323 -- Simple protected objects which use type System.Tasking.
2324 -- Protected_Objects.Protection to manage their locks should
2325 -- be treated as controlled since they require manual cleanup.
2326 -- The only exception is illustrated in the following example:
2329 -- type Ctrl is new Controlled ...
2330 -- procedure Finalize (Obj : in out Ctrl);
2334 -- package body Pkg is
2335 -- protected Prot is
2336 -- procedure Do_Something (Obj : in out Ctrl);
2339 -- protected body Prot is
2340 -- procedure Do_Something (Obj : in out Ctrl) is ...
2343 -- procedure Finalize (Obj : in out Ctrl) is
2345 -- Prot.Do_Something (Obj);
2349 -- Since for the most part entities in package bodies depend on
2350 -- those in package specs, Prot's lock should be cleaned up
2351 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2352 -- This act however attempts to invoke Do_Something and fails
2353 -- because the lock has disappeared.
2355 elsif Ekind (Obj_Id) = E_Variable
2356 and then not In_Library_Level_Package_Body (Obj_Id)
2357 and then (Is_Simple_Protected_Type (Obj_Typ)
2358 or else Has_Simple_Protected_Object (Obj_Typ))
2360 Processing_Actions (Is_Protected => True);
2363 -- Specific cases of object renamings
2365 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2366 Obj_Id := Defining_Identifier (Decl);
2367 Obj_Typ := Base_Type (Etype (Obj_Id));
2369 -- Bypass any form of processing for objects which have their
2370 -- finalization disabled. This applies only to objects at the
2373 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2376 -- Ignored Ghost object renamings do not need any cleanup
2377 -- actions because they will not appear in the final tree.
2379 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2382 -- Return object of a build-in-place function. This case is
2383 -- recognized and marked by the expansion of an extended return
2384 -- statement (see Expand_N_Extended_Return_Statement).
2386 elsif Needs_Finalization (Obj_Typ)
2387 and then Is_Return_Object (Obj_Id)
2388 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2390 Processing_Actions (Has_No_Init => True);
2392 -- Detect a case where a source object has been initialized by
2393 -- a controlled function call or another object which was later
2394 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2396 -- Obj1 : CW_Type := Src_Obj;
2397 -- Obj2 : CW_Type := Function_Call (...);
2399 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2400 -- Tmp : ... := Function_Call (...)'reference;
2401 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2403 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
2404 Processing_Actions (Has_No_Init => True);
2407 -- Inspect the freeze node of an access-to-controlled type and
2408 -- look for a delayed finalization master. This case arises when
2409 -- the freeze actions are inserted at a later time than the
2410 -- expansion of the context. Since Build_Finalizer is never called
2411 -- on a single construct twice, the master will be ultimately
2412 -- left out and never finalized. This is also needed for freeze
2413 -- actions of designated types themselves, since in some cases the
2414 -- finalization master is associated with a designated type's
2415 -- freeze node rather than that of the access type (see handling
2416 -- for freeze actions in Build_Finalization_Master).
2418 elsif Nkind (Decl) = N_Freeze_Entity
2419 and then Present (Actions (Decl))
2421 Typ := Entity (Decl);
2423 -- Freeze nodes for ignored Ghost types do not need cleanup
2424 -- actions because they will never appear in the final tree.
2426 if Is_Ignored_Ghost_Entity (Typ) then
2429 elsif (Is_Access_Object_Type (Typ)
2430 and then Needs_Finalization
2431 (Available_View (Designated_Type (Typ))))
2432 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2434 Old_Counter_Val := Counter_Val;
2436 -- Freeze nodes are considered to be identical to packages
2437 -- and blocks in terms of nesting. The difference is that
2438 -- a finalization master created inside the freeze node is
2439 -- at the same nesting level as the node itself.
2441 Process_Declarations (Actions (Decl), Preprocess);
2443 -- The freeze node contains a finalization master
2447 and then No (Last_Top_Level_Ctrl_Construct)
2448 and then Counter_Val > Old_Counter_Val
2450 Last_Top_Level_Ctrl_Construct := Decl;
2454 -- Nested package declarations, avoid generics
2456 elsif Nkind (Decl) = N_Package_Declaration then
2457 Pack_Id := Defining_Entity (Decl);
2458 Spec := Specification (Decl);
2460 -- Do not inspect an ignored Ghost package because all code
2461 -- found within will not appear in the final tree.
2463 if Is_Ignored_Ghost_Entity (Pack_Id) then
2466 elsif Ekind (Pack_Id) /= E_Generic_Package then
2467 Old_Counter_Val := Counter_Val;
2468 Process_Declarations
2469 (Private_Declarations (Spec), Preprocess);
2470 Process_Declarations
2471 (Visible_Declarations (Spec), Preprocess);
2473 -- Either the visible or the private declarations contain a
2474 -- controlled object. The nested package declaration is the
2475 -- last such construct.
2479 and then No (Last_Top_Level_Ctrl_Construct)
2480 and then Counter_Val > Old_Counter_Val
2482 Last_Top_Level_Ctrl_Construct := Decl;
2486 -- Call the xxx__finalize_body procedure of a library level
2487 -- package instantiation if the body contains finalization
2490 if Present (Generic_Parent (Spec))
2491 and then Is_Library_Level_Entity (Pack_Id)
2492 and then Present (Body_Entity (Generic_Parent (Spec)))
2498 P := Parent (Body_Entity (Generic_Parent (Spec)));
2500 and then Nkind (P) /= N_Package_Body
2506 Old_Counter_Val := Counter_Val;
2507 Process_Declarations (Declarations (P), Preprocess);
2509 -- Note that we are processing the generic body
2510 -- template and not the actually instantiation
2511 -- (which is generated too late for us to process
2512 -- it), so there is no need to update in particular
2513 -- Last_Top_Level_Ctrl_Construct here.
2515 if Counter_Val > Old_Counter_Val then
2516 Counter_Val := Old_Counter_Val;
2517 Set_Has_Controlled_Component (Pack_Id);
2522 elsif Has_Controlled_Component (Pack_Id) then
2524 -- We import the xxx__finalize_body routine since the
2525 -- generic body will be instantiated later.
2528 Id : constant Node_Id :=
2529 Make_Defining_Identifier (Loc,
2530 New_Finalizer_Name (Defining_Unit_Name (Spec),
2531 For_Spec => False));
2534 Set_Has_Qualified_Name (Id);
2535 Set_Has_Fully_Qualified_Name (Id);
2536 Set_Is_Imported (Id);
2537 Set_Has_Completion (Id);
2538 Set_Interface_Name (Id,
2539 Make_String_Literal (Loc,
2540 Strval => Get_Name_String (Chars (Id))));
2542 Append_New_To (Finalizer_Stmts,
2543 Make_Subprogram_Declaration (Loc,
2544 Make_Procedure_Specification (Loc,
2545 Defining_Unit_Name => Id)));
2546 Append_To (Finalizer_Stmts,
2547 Make_Procedure_Call_Statement (Loc,
2548 Name => New_Occurrence_Of (Id, Loc)));
2553 -- Nested package bodies, avoid generics
2555 elsif Nkind (Decl) = N_Package_Body then
2557 -- Do not inspect an ignored Ghost package body because all
2558 -- code found within will not appear in the final tree.
2560 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2563 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
2565 Old_Counter_Val := Counter_Val;
2566 Process_Declarations (Declarations (Decl), Preprocess);
2568 -- The nested package body is the last construct to contain
2569 -- a controlled object.
2573 and then No (Last_Top_Level_Ctrl_Construct)
2574 and then Counter_Val > Old_Counter_Val
2576 Last_Top_Level_Ctrl_Construct := Decl;
2580 -- Handle a rare case caused by a controlled transient object
2581 -- created as part of a record init proc. The variable is wrapped
2582 -- in a block, but the block is not associated with a transient
2585 elsif Nkind (Decl) = N_Block_Statement
2586 and then Inside_Init_Proc
2588 Old_Counter_Val := Counter_Val;
2590 if Present (Handled_Statement_Sequence (Decl)) then
2591 Process_Declarations
2592 (Statements (Handled_Statement_Sequence (Decl)),
2596 Process_Declarations (Declarations (Decl), Preprocess);
2598 -- Either the declaration or statement list of the block has a
2599 -- controlled object.
2603 and then No (Last_Top_Level_Ctrl_Construct)
2604 and then Counter_Val > Old_Counter_Val
2606 Last_Top_Level_Ctrl_Construct := Decl;
2609 -- Handle the case where the original context has been wrapped in
2610 -- a block to avoid interference between exception handlers and
2611 -- At_End handlers. Treat the block as transparent and process its
2614 elsif Nkind (Decl) = N_Block_Statement
2615 and then Is_Finalization_Wrapper (Decl)
2617 if Present (Handled_Statement_Sequence (Decl)) then
2618 Process_Declarations
2619 (Statements (Handled_Statement_Sequence (Decl)),
2623 Process_Declarations (Declarations (Decl), Preprocess);
2626 Prev_Non_Pragma (Decl);
2628 end Process_Declarations;
2630 --------------------------------
2631 -- Process_Object_Declaration --
2632 --------------------------------
2634 procedure Process_Object_Declaration
2636 Has_No_Init : Boolean := False;
2637 Is_Protected : Boolean := False)
2639 Loc : constant Source_Ptr := Sloc (Decl);
2640 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2642 Init_Typ : Entity_Id;
2643 -- The initialization type of the related object declaration. Note
2644 -- that this is not necessarily the same type as Obj_Typ because of
2645 -- possible type derivations.
2647 Obj_Typ : Entity_Id;
2648 -- The type of the related object declaration
2650 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2651 -- Func_Id denotes a build-in-place function. Generate the following
2654 -- if BIPallocfrom > Secondary_Stack'Pos
2655 -- and then BIPfinalizationmaster /= null
2658 -- type Ptr_Typ is access Obj_Typ;
2659 -- for Ptr_Typ'Storage_Pool
2660 -- use Base_Pool (BIPfinalizationmaster);
2662 -- Free (Ptr_Typ (Temp));
2666 -- Obj_Typ is the type of the current object, Temp is the original
2667 -- allocation which Obj_Id renames.
2669 procedure Find_Last_Init
2670 (Last_Init : out Node_Id;
2671 Body_Insert : out Node_Id);
2672 -- Find the last initialization call related to object declaration
2673 -- Decl. Last_Init denotes the last initialization call which follows
2674 -- Decl. Body_Insert denotes a node where the finalizer body could be
2675 -- potentially inserted after (if blocks are involved).
2677 -----------------------------
2678 -- Build_BIP_Cleanup_Stmts --
2679 -----------------------------
2681 function Build_BIP_Cleanup_Stmts
2682 (Func_Id : Entity_Id) return Node_Id
2684 Decls : constant List_Id := New_List;
2685 Fin_Mas_Id : constant Entity_Id :=
2686 Build_In_Place_Formal
2687 (Func_Id, BIP_Finalization_Master);
2688 Func_Typ : constant Entity_Id := Etype (Func_Id);
2689 Temp_Id : constant Entity_Id :=
2690 Entity (Prefix (Name (Parent (Obj_Id))));
2694 Free_Stmt : Node_Id;
2695 Pool_Id : Entity_Id;
2696 Ptr_Typ : Entity_Id;
2700 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2702 Pool_Id := Make_Temporary (Loc, 'P');
2705 Make_Object_Renaming_Declaration (Loc,
2706 Defining_Identifier => Pool_Id,
2708 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2710 Make_Explicit_Dereference (Loc,
2712 Make_Function_Call (Loc,
2714 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2715 Parameter_Associations => New_List (
2716 Make_Explicit_Dereference (Loc,
2718 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2720 -- Create an access type which uses the storage pool of the
2721 -- caller's finalization master.
2724 -- type Ptr_Typ is access Func_Typ;
2726 Ptr_Typ := Make_Temporary (Loc, 'P');
2729 Make_Full_Type_Declaration (Loc,
2730 Defining_Identifier => Ptr_Typ,
2732 Make_Access_To_Object_Definition (Loc,
2733 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2735 -- Perform minor decoration in order to set the master and the
2736 -- storage pool attributes.
2738 Mutate_Ekind (Ptr_Typ, E_Access_Type);
2739 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2740 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2742 if Debug_Generated_Code then
2743 Set_Debug_Info_Needed (Pool_Id);
2746 -- Create an explicit free statement. Note that the free uses the
2747 -- caller's pool expressed as a renaming.
2750 Make_Free_Statement (Loc,
2752 Unchecked_Convert_To (Ptr_Typ,
2753 New_Occurrence_Of (Temp_Id, Loc)));
2755 Set_Storage_Pool (Free_Stmt, Pool_Id);
2757 -- Create a block to house the dummy type and the instantiation as
2758 -- well as to perform the cleanup the temporary.
2764 -- Free (Ptr_Typ (Temp_Id));
2768 Make_Block_Statement (Loc,
2769 Declarations => Decls,
2770 Handled_Statement_Sequence =>
2771 Make_Handled_Sequence_Of_Statements (Loc,
2772 Statements => New_List (Free_Stmt)));
2775 -- if BIPfinalizationmaster /= null then
2779 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2780 Right_Opnd => Make_Null (Loc));
2782 -- For unconstrained or tagged results, escalate the condition to
2783 -- include the allocation format. Generate:
2785 -- if BIPallocform > Secondary_Stack'Pos
2786 -- and then BIPfinalizationmaster /= null
2789 if Needs_BIP_Alloc_Form (Func_Id) then
2791 Alloc : constant Entity_Id :=
2792 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2798 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2800 Make_Integer_Literal (Loc,
2802 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2804 Right_Opnd => Cond);
2814 Make_If_Statement (Loc,
2816 Then_Statements => New_List (Free_Blk));
2817 end Build_BIP_Cleanup_Stmts;
2819 --------------------
2820 -- Find_Last_Init --
2821 --------------------
2823 procedure Find_Last_Init
2824 (Last_Init : out Node_Id;
2825 Body_Insert : out Node_Id)
2827 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2828 -- Find the last initialization call within the statements of
2831 function Is_Init_Call (N : Node_Id) return Boolean;
2832 -- Determine whether node N denotes one of the initialization
2833 -- procedures of types Init_Typ or Obj_Typ.
2835 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2836 -- Obtain the next statement which follows list member Stmt while
2837 -- ignoring artifacts related to access-before-elaboration checks.
2839 -----------------------------
2840 -- Find_Last_Init_In_Block --
2841 -----------------------------
2843 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2844 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2848 -- Examine the individual statements of the block in reverse to
2849 -- locate the last initialization call.
2851 if Present (HSS) and then Present (Statements (HSS)) then
2852 Stmt := Last (Statements (HSS));
2853 while Present (Stmt) loop
2855 -- Peek inside nested blocks in case aborts are allowed
2857 if Nkind (Stmt) = N_Block_Statement then
2858 return Find_Last_Init_In_Block (Stmt);
2860 elsif Is_Init_Call (Stmt) then
2869 end Find_Last_Init_In_Block;
2875 function Is_Init_Call (N : Node_Id) return Boolean is
2876 function Is_Init_Proc_Of
2877 (Subp_Id : Entity_Id;
2878 Typ : Entity_Id) return Boolean;
2879 -- Determine whether subprogram Subp_Id is a valid init proc of
2882 ---------------------
2883 -- Is_Init_Proc_Of --
2884 ---------------------
2886 function Is_Init_Proc_Of
2887 (Subp_Id : Entity_Id;
2888 Typ : Entity_Id) return Boolean
2890 Deep_Init : Entity_Id := Empty;
2891 Prim_Init : Entity_Id := Empty;
2892 Type_Init : Entity_Id := Empty;
2895 -- Obtain all possible initialization routines of the
2896 -- related type and try to match the subprogram entity
2897 -- against one of them.
2901 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2903 -- Primitive Initialize
2905 if Is_Controlled (Typ) then
2906 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2908 if Present (Prim_Init) then
2909 Prim_Init := Ultimate_Alias (Prim_Init);
2913 -- Type initialization routine
2915 if Has_Non_Null_Base_Init_Proc (Typ) then
2916 Type_Init := Base_Init_Proc (Typ);
2920 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2922 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2924 (Present (Type_Init) and then Subp_Id = Type_Init);
2925 end Is_Init_Proc_Of;
2929 Call_Id : Entity_Id;
2931 -- Start of processing for Is_Init_Call
2934 if Nkind (N) = N_Procedure_Call_Statement
2935 and then Nkind (Name (N)) = N_Identifier
2937 Call_Id := Entity (Name (N));
2939 -- Consider both the type of the object declaration and its
2940 -- related initialization type.
2943 Is_Init_Proc_Of (Call_Id, Init_Typ)
2945 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2951 -----------------------------
2952 -- Next_Suitable_Statement --
2953 -----------------------------
2955 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2959 -- Skip call markers and Program_Error raises installed by the
2962 Result := Next (Stmt);
2963 while Present (Result) loop
2964 exit when Nkind (Result) not in
2965 N_Call_Marker | N_Raise_Program_Error;
2971 end Next_Suitable_Statement;
2979 Deep_Init_Found : Boolean := False;
2980 -- A flag set when a call to [Deep_]Initialize has been found
2982 -- Start of processing for Find_Last_Init
2986 Body_Insert := Empty;
2988 -- Object renamings and objects associated with controlled
2989 -- function results do not require initialization.
2995 Stmt := Next_Suitable_Statement (Decl);
2997 -- For an object with suppressed initialization, we check whether
2998 -- there is in fact no initialization expression. If there is not,
2999 -- then this is an object declaration that has been turned into a
3000 -- different object declaration that calls the build-in-place
3001 -- function in a 'Reference attribute, as in "F(...)'Reference".
3002 -- We search for that later object declaration, so that the
3003 -- Inc_Decl will be inserted after the call. Otherwise, if the
3004 -- call raises an exception, we will finalize the (uninitialized)
3005 -- object, which is wrong.
3007 if No_Initialization (Decl) then
3008 if No (Expression (Last_Init)) then
3011 exit when No (Last_Init);
3012 exit when Nkind (Last_Init) = N_Object_Declaration
3013 and then Nkind (Expression (Last_Init)) = N_Reference
3014 and then Nkind (Prefix (Expression (Last_Init))) =
3016 and then Is_Expanded_Build_In_Place_Call
3017 (Prefix (Expression (Last_Init)));
3023 -- If the initialization is in the declaration, we're done, so
3024 -- early return if we have no more statements or they have been
3025 -- rewritten, which means that they were in the source code.
3027 elsif No (Stmt) or else Original_Node (Stmt) /= Stmt then
3030 -- In all other cases the initialization calls follow the related
3031 -- object. The general structure of object initialization built by
3032 -- routine Default_Initialize_Object is as follows:
3034 -- [begin -- aborts allowed
3036 -- Type_Init_Proc (Obj);
3037 -- [begin] -- exceptions allowed
3038 -- Deep_Initialize (Obj);
3039 -- [exception -- exceptions allowed
3041 -- Deep_Finalize (Obj, Self => False);
3044 -- [at end -- aborts allowed
3048 -- When aborts are allowed, the initialization calls are housed
3051 elsif Nkind (Stmt) = N_Block_Statement then
3052 Last_Init := Find_Last_Init_In_Block (Stmt);
3053 Body_Insert := Stmt;
3055 -- Otherwise the initialization calls follow the related object
3058 Stmt_2 := Next_Suitable_Statement (Stmt);
3060 -- Check for an optional call to Deep_Initialize which may
3061 -- appear within a block depending on whether the object has
3062 -- controlled components.
3064 if Present (Stmt_2) then
3065 if Nkind (Stmt_2) = N_Block_Statement then
3066 Call := Find_Last_Init_In_Block (Stmt_2);
3068 if Present (Call) then
3069 Deep_Init_Found := True;
3071 Body_Insert := Stmt_2;
3074 elsif Is_Init_Call (Stmt_2) then
3075 Deep_Init_Found := True;
3076 Last_Init := Stmt_2;
3077 Body_Insert := Last_Init;
3081 -- If the object lacks a call to Deep_Initialize, then it must
3082 -- have a call to its related type init proc.
3084 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
3086 Body_Insert := Last_Init;
3094 Count_Ins : Node_Id;
3096 Fin_Stmts : List_Id := No_List;
3099 Label_Id : Entity_Id;
3102 -- Start of processing for Process_Object_Declaration
3105 -- Handle the object type and the reference to the object
3107 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
3108 Obj_Typ := Base_Type (Etype (Obj_Id));
3111 if Is_Access_Type (Obj_Typ) then
3112 Obj_Typ := Directly_Designated_Type (Obj_Typ);
3113 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
3115 elsif Is_Concurrent_Type (Obj_Typ)
3116 and then Present (Corresponding_Record_Type (Obj_Typ))
3118 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
3119 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3121 elsif Is_Private_Type (Obj_Typ)
3122 and then Present (Full_View (Obj_Typ))
3124 Obj_Typ := Full_View (Obj_Typ);
3125 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3127 elsif Obj_Typ /= Base_Type (Obj_Typ) then
3128 Obj_Typ := Base_Type (Obj_Typ);
3129 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3136 Set_Etype (Obj_Ref, Obj_Typ);
3138 -- Handle the initialization type of the object declaration
3140 Init_Typ := Obj_Typ;
3142 if Is_Private_Type (Init_Typ)
3143 and then Present (Full_View (Init_Typ))
3145 Init_Typ := Full_View (Init_Typ);
3147 elsif Is_Untagged_Derivation (Init_Typ) then
3148 Init_Typ := Root_Type (Init_Typ);
3155 -- Set a new value for the state counter and insert the statement
3156 -- after the object declaration. Generate:
3158 -- Counter := <value>;
3161 Make_Assignment_Statement (Loc,
3162 Name => New_Occurrence_Of (Counter_Id, Loc),
3163 Expression => Make_Integer_Literal (Loc, Counter_Val));
3165 -- Insert the counter after all initialization has been done. The
3166 -- place of insertion depends on the context.
3168 if Ekind (Obj_Id) in E_Constant | E_Variable then
3170 -- The object is initialized by a build-in-place function call.
3171 -- The counter insertion point is after the function call.
3173 if Present (BIP_Initialization_Call (Obj_Id)) then
3174 Count_Ins := BIP_Initialization_Call (Obj_Id);
3177 -- The object is initialized by an aggregate. Insert the counter
3178 -- after the last aggregate assignment.
3180 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
3181 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
3184 -- In all other cases the counter is inserted after the last call
3185 -- to either [Deep_]Initialize or the type-specific init proc.
3188 Find_Last_Init (Count_Ins, Body_Ins);
3191 -- In all other cases the counter is inserted after the last call to
3192 -- either [Deep_]Initialize or the type-specific init proc.
3195 Find_Last_Init (Count_Ins, Body_Ins);
3198 -- If the Initialize function is null or trivial, the call will have
3199 -- been replaced with a null statement, in which case place counter
3200 -- declaration after object declaration itself.
3202 if No (Count_Ins) then
3206 Insert_After (Count_Ins, Inc_Decl);
3209 -- If the current declaration is the last in the list, the finalizer
3210 -- body needs to be inserted after the set counter statement for the
3211 -- current object declaration. This is complicated by the fact that
3212 -- the set counter statement may appear in abort deferred block. In
3213 -- that case, the proper insertion place is after the block.
3215 if No (Finalizer_Insert_Nod) then
3217 -- Insertion after an abort deferred block
3219 if Present (Body_Ins) then
3220 Finalizer_Insert_Nod := Body_Ins;
3222 Finalizer_Insert_Nod := Inc_Decl;
3226 -- Create the associated label with this object, generate:
3228 -- L<counter> : label;
3231 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
3233 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
3234 Label := Make_Label (Loc, Label_Id);
3236 Prepend_To (Finalizer_Decls,
3237 Make_Implicit_Label_Declaration (Loc,
3238 Defining_Identifier => Entity (Label_Id),
3239 Label_Construct => Label));
3241 -- Create the associated jump with this object, generate:
3243 -- when <counter> =>
3246 Prepend_To (Jump_Alts,
3247 Make_Case_Statement_Alternative (Loc,
3248 Discrete_Choices => New_List (
3249 Make_Integer_Literal (Loc, Counter_Val)),
3250 Statements => New_List (
3251 Make_Goto_Statement (Loc,
3252 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
3254 -- Insert the jump destination, generate:
3258 Append_To (Finalizer_Stmts, Label);
3260 -- Disable warnings on Obj_Id. This works around an issue where GCC
3261 -- is not able to detect that Obj_Id is protected by a counter and
3262 -- emits spurious warnings.
3264 if not Comes_From_Source (Obj_Id) then
3265 Set_Warnings_Off (Obj_Id);
3268 -- Processing for simple protected objects. Such objects require
3269 -- manual finalization of their lock managers.
3271 if Is_Protected then
3272 if Is_Simple_Protected_Type (Obj_Typ) then
3273 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3275 if Present (Fin_Call) then
3276 Fin_Stmts := New_List (Fin_Call);
3279 elsif Has_Simple_Protected_Object (Obj_Typ) then
3280 if Is_Record_Type (Obj_Typ) then
3281 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3282 elsif Is_Array_Type (Obj_Typ) then
3283 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3289 -- System.Tasking.Protected_Objects.Finalize_Protection
3297 if Present (Fin_Stmts) and then Exceptions_OK then
3298 Fin_Stmts := New_List (
3299 Make_Block_Statement (Loc,
3300 Handled_Statement_Sequence =>
3301 Make_Handled_Sequence_Of_Statements (Loc,
3302 Statements => Fin_Stmts,
3304 Exception_Handlers => New_List (
3305 Make_Exception_Handler (Loc,
3306 Exception_Choices => New_List (
3307 Make_Others_Choice (Loc)),
3309 Statements => New_List (
3310 Make_Null_Statement (Loc)))))));
3313 -- Processing for regular controlled objects
3318 -- [Deep_]Finalize (Obj);
3321 -- when Id : others =>
3322 -- if not Raised then
3324 -- Save_Occurrence (E, Id);
3333 -- Guard against a missing [Deep_]Finalize when the object type
3334 -- was not properly frozen.
3336 if No (Fin_Call) then
3337 Fin_Call := Make_Null_Statement (Loc);
3340 -- For CodePeer, the exception handlers normally generated here
3341 -- generate complex flowgraphs which result in capacity problems.
3342 -- Omitting these handlers for CodePeer is justified as follows:
3344 -- If a handler is dead, then omitting it is surely ok
3346 -- If a handler is live, then CodePeer should flag the
3347 -- potentially-exception-raising construct that causes it
3348 -- to be live. That is what we are interested in, not what
3349 -- happens after the exception is raised.
3351 if Exceptions_OK and not CodePeer_Mode then
3352 Fin_Stmts := New_List (
3353 Make_Block_Statement (Loc,
3354 Handled_Statement_Sequence =>
3355 Make_Handled_Sequence_Of_Statements (Loc,
3356 Statements => New_List (Fin_Call),
3358 Exception_Handlers => New_List (
3359 Build_Exception_Handler
3360 (Finalizer_Data, For_Package)))));
3362 -- When exception handlers are prohibited, the finalization call
3363 -- appears unprotected. Any exception raised during finalization
3364 -- will bypass the circuitry which ensures the cleanup of all
3365 -- remaining objects.
3368 Fin_Stmts := New_List (Fin_Call);
3371 -- If we are dealing with a return object of a build-in-place
3372 -- function, generate the following cleanup statements:
3374 -- if BIPallocfrom > Secondary_Stack'Pos
3375 -- and then BIPfinalizationmaster /= null
3378 -- type Ptr_Typ is access Obj_Typ;
3379 -- for Ptr_Typ'Storage_Pool use
3380 -- Base_Pool (BIPfinalizationmaster.all).all;
3382 -- Free (Ptr_Typ (Temp));
3386 -- The generated code effectively detaches the temporary from the
3387 -- caller finalization master and deallocates the object.
3389 if Is_Return_Object (Obj_Id) then
3391 Func_Id : constant Entity_Id :=
3392 Return_Applies_To (Scope (Obj_Id));
3395 if Is_Build_In_Place_Function (Func_Id)
3396 and then Needs_BIP_Finalization_Master (Func_Id)
3398 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3403 if Ekind (Obj_Id) in E_Constant | E_Variable
3404 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3406 -- Temporaries created for the purpose of "exporting" a
3407 -- transient object out of an Expression_With_Actions (EWA)
3408 -- need guards. The following illustrates the usage of such
3411 -- Access_Typ : access [all] Obj_Typ;
3412 -- Temp : Access_Typ := null;
3413 -- <Counter> := ...;
3416 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3417 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3419 -- Temp := Ctrl_Trans'Unchecked_Access;
3422 -- The finalization machinery does not process EWA nodes as
3423 -- this may lead to premature finalization of expressions. Note
3424 -- that Temp is marked as being properly initialized regardless
3425 -- of whether the initialization of Ctrl_Trans succeeded. Since
3426 -- a failed initialization may leave Temp with a value of null,
3427 -- add a guard to handle this case:
3429 -- if Obj /= null then
3430 -- <object finalization statements>
3433 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3434 N_Object_Declaration
3436 Fin_Stmts := New_List (
3437 Make_If_Statement (Loc,
3440 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3441 Right_Opnd => Make_Null (Loc)),
3442 Then_Statements => Fin_Stmts));
3444 -- Return objects use a flag to aid in processing their
3445 -- potential finalization when the enclosing function fails
3446 -- to return properly. Generate:
3449 -- <object finalization statements>
3453 Fin_Stmts := New_List (
3454 Make_If_Statement (Loc,
3459 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3461 Then_Statements => Fin_Stmts));
3466 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3468 -- Since the declarations are examined in reverse, the state counter
3469 -- must be decremented in order to keep with the true position of
3472 Counter_Val := Counter_Val - 1;
3473 end Process_Object_Declaration;
3475 -------------------------------------
3476 -- Process_Tagged_Type_Declaration --
3477 -------------------------------------
3479 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3480 Typ : constant Entity_Id := Defining_Identifier (Decl);
3481 DT_Ptr : constant Entity_Id :=
3482 Node (First_Elmt (Access_Disp_Table (Typ)));
3485 -- Ada.Tags.Unregister_Tag (<Typ>P);
3487 Append_To (Tagged_Type_Stmts,
3488 Make_Procedure_Call_Statement (Loc,
3490 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3491 Parameter_Associations => New_List (
3492 New_Occurrence_Of (DT_Ptr, Loc))));
3493 end Process_Tagged_Type_Declaration;
3495 -- Start of processing for Build_Finalizer
3500 -- Do not perform this expansion in SPARK mode because it is not
3503 if GNATprove_Mode then
3507 -- Step 1: Extract all lists which may contain controlled objects or
3508 -- library-level tagged types.
3510 if For_Package_Spec then
3511 Decls := Visible_Declarations (Specification (N));
3512 Priv_Decls := Private_Declarations (Specification (N));
3514 -- Retrieve the package spec id
3516 Spec_Id := Defining_Unit_Name (Specification (N));
3518 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3519 Spec_Id := Defining_Identifier (Spec_Id);
3522 -- Accept statement, block, entry body, package body, protected body,
3523 -- subprogram body or task body.
3526 Decls := Declarations (N);
3527 HSS := Handled_Statement_Sequence (N);
3529 if Present (HSS) then
3530 if Present (Statements (HSS)) then
3531 Stmts := Statements (HSS);
3534 if Present (At_End_Proc (HSS)) then
3535 Prev_At_End := At_End_Proc (HSS);
3539 -- Retrieve the package spec id for package bodies
3541 if For_Package_Body then
3542 Spec_Id := Corresponding_Spec (N);
3546 -- Do not process nested packages since those are handled by the
3547 -- enclosing scope's finalizer. Do not process non-expanded package
3548 -- instantiations since those will be re-analyzed and re-expanded.
3552 (not Is_Library_Level_Entity (Spec_Id)
3554 -- Nested packages are library level entities, but do not need to
3555 -- be processed separately.
3557 or else Scope_Depth (Spec_Id) /= Uint_1
3558 or else (Is_Generic_Instance (Spec_Id)
3559 and then Package_Instantiation (Spec_Id) /= N))
3561 -- Still need to process package body instantiations which may
3562 -- contain objects requiring finalization.
3566 and then Is_Library_Level_Entity (Spec_Id)
3567 and then Is_Generic_Instance (Spec_Id))
3572 -- Step 2: Object [pre]processing
3576 -- Preprocess the visible declarations now in order to obtain the
3577 -- correct number of controlled object by the time the private
3578 -- declarations are processed.
3580 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3582 -- From all the possible contexts, only package specifications may
3583 -- have private declarations.
3585 if For_Package_Spec then
3586 Process_Declarations
3587 (Priv_Decls, Preprocess => True, Top_Level => True);
3590 -- The current context may lack controlled objects, but require some
3591 -- other form of completion (task termination for instance). In such
3592 -- cases, the finalizer must be created and carry the additional
3595 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3599 -- The preprocessing has determined that the context has controlled
3600 -- objects or library-level tagged types.
3602 if Has_Ctrl_Objs or Has_Tagged_Types then
3604 -- Private declarations are processed first in order to preserve
3605 -- possible dependencies between public and private objects.
3607 if For_Package_Spec then
3608 Process_Declarations (Priv_Decls);
3611 Process_Declarations (Decls);
3617 -- Preprocess both declarations and statements
3619 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3620 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3622 -- At this point it is known that N has controlled objects. Ensure
3623 -- that N has a declarative list since the finalizer spec will be
3626 if Has_Ctrl_Objs and then No (Decls) then
3627 Set_Declarations (N, New_List);
3628 Decls := Declarations (N);
3629 Spec_Decls := Decls;
3632 -- The current context may lack controlled objects, but require some
3633 -- other form of completion (task termination for instance). In such
3634 -- cases, the finalizer must be created and carry the additional
3637 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3641 if Has_Ctrl_Objs or Has_Tagged_Types then
3642 Process_Declarations (Stmts);
3643 Process_Declarations (Decls);
3647 -- Step 3: Finalizer creation
3649 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3652 end Build_Finalizer;
3654 --------------------------
3655 -- Build_Finalizer_Call --
3656 --------------------------
3658 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3660 -- Do not perform this expansion in SPARK mode because we do not create
3661 -- finalizers in the first place.
3663 if GNATprove_Mode then
3667 -- If the construct to be cleaned up is a protected subprogram body, the
3668 -- finalizer call needs to be associated with the block that wraps the
3669 -- unprotected version of the subprogram. The following illustrates this
3672 -- procedure Prot_SubpP is
3673 -- procedure finalizer is
3675 -- Service_Entries (Prot_Obj);
3682 -- Prot_SubpN (Prot_Obj);
3689 Loc : constant Source_Ptr := Sloc (N);
3691 Is_Protected_Subp_Body : constant Boolean :=
3692 Nkind (N) = N_Subprogram_Body
3693 and then Is_Protected_Subprogram_Body (N);
3694 -- True if N is the protected version of a subprogram that belongs to
3695 -- a protected type.
3697 HSS : constant Node_Id :=
3698 (if Is_Protected_Subp_Body
3699 then Handled_Statement_Sequence
3700 (Last (Statements (Handled_Statement_Sequence (N))))
3701 else Handled_Statement_Sequence (N));
3703 -- We attach the At_End_Proc to the HSS if this is an accept
3704 -- statement or extended return statement. Also in the case of
3705 -- a protected subprogram, because if Service_Entries raises an
3706 -- exception, we do not lock the PO, so we also do not want to
3709 Use_HSS : constant Boolean :=
3710 Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement
3711 or else Is_Protected_Subp_Body;
3713 At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N);
3715 pragma Assert (No (At_End_Proc (At_End_Proc_Bearer)));
3716 Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc));
3717 -- Attach reference to finalizer to tree, for LLVM use
3718 Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer);
3719 Analyze (At_End_Proc (At_End_Proc_Bearer));
3720 Expand_At_End_Handler (At_End_Proc_Bearer, Empty);
3722 end Build_Finalizer_Call;
3724 ---------------------
3725 -- Build_Late_Proc --
3726 ---------------------
3728 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3730 for Final_Prim in Name_Of'Range loop
3731 if Name_Of (Final_Prim) = Nam then
3734 (Prim => Final_Prim,
3736 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3739 end Build_Late_Proc;
3741 -------------------------------
3742 -- Build_Object_Declarations --
3743 -------------------------------
3745 procedure Build_Object_Declarations
3746 (Data : out Finalization_Exception_Data;
3749 For_Package : Boolean := False)
3754 -- This variable captures an unused dummy internal entity, see the
3755 -- comment associated with its use.
3758 pragma Assert (Decls /= No_List);
3760 -- Always set the proper location as it may be needed even when
3761 -- exception propagation is forbidden.
3765 if Restriction_Active (No_Exception_Propagation) then
3766 Data.Abort_Id := Empty;
3768 Data.Raised_Id := Empty;
3772 Data.Raised_Id := Make_Temporary (Loc, 'R');
3774 -- In certain scenarios, finalization can be triggered by an abort. If
3775 -- the finalization itself fails and raises an exception, the resulting
3776 -- Program_Error must be supressed and replaced by an abort signal. In
3777 -- order to detect this scenario, save the state of entry into the
3778 -- finalization code.
3780 -- This is not needed for library-level finalizers as they are called by
3781 -- the environment task and cannot be aborted.
3783 if not For_Package then
3784 if Abort_Allowed then
3785 Data.Abort_Id := Make_Temporary (Loc, 'A');
3788 -- Abort_Id : constant Boolean := <A_Expr>;
3791 Make_Object_Declaration (Loc,
3792 Defining_Identifier => Data.Abort_Id,
3793 Constant_Present => True,
3794 Object_Definition =>
3795 New_Occurrence_Of (Standard_Boolean, Loc),
3797 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3799 -- Abort is not required
3802 -- Generate a dummy entity to ensure that the internal symbols are
3803 -- in sync when a unit is compiled with and without aborts.
3805 Dummy := Make_Temporary (Loc, 'A');
3806 Data.Abort_Id := Empty;
3809 -- Library-level finalizers
3812 Data.Abort_Id := Empty;
3815 if Exception_Extra_Info then
3816 Data.E_Id := Make_Temporary (Loc, 'E');
3819 -- E_Id : Exception_Occurrence;
3822 Make_Object_Declaration (Loc,
3823 Defining_Identifier => Data.E_Id,
3824 Object_Definition =>
3825 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3826 Set_No_Initialization (Decl);
3828 Append_To (Decls, Decl);
3835 -- Raised_Id : Boolean := False;
3838 Make_Object_Declaration (Loc,
3839 Defining_Identifier => Data.Raised_Id,
3840 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3841 Expression => New_Occurrence_Of (Standard_False, Loc)));
3843 if Debug_Generated_Code then
3844 Set_Debug_Info_Needed (Data.Raised_Id);
3846 end Build_Object_Declarations;
3848 ---------------------------
3849 -- Build_Raise_Statement --
3850 ---------------------------
3852 function Build_Raise_Statement
3853 (Data : Finalization_Exception_Data) return Node_Id
3859 -- Standard run-time use the specialized routine
3860 -- Raise_From_Controlled_Operation.
3862 if Exception_Extra_Info
3863 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3866 Make_Procedure_Call_Statement (Data.Loc,
3869 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3870 Parameter_Associations =>
3871 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3873 -- Restricted run-time: exception messages are not supported and hence
3874 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3879 Make_Raise_Program_Error (Data.Loc,
3880 Reason => PE_Finalize_Raised_Exception);
3885 -- Raised_Id and then not Abort_Id
3889 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3891 if Present (Data.Abort_Id) then
3892 Expr := Make_And_Then (Data.Loc,
3895 Make_Op_Not (Data.Loc,
3896 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3901 -- if Raised_Id and then not Abort_Id then
3902 -- Raise_From_Controlled_Operation (E_Id);
3904 -- raise Program_Error; -- restricted runtime
3908 Make_If_Statement (Data.Loc,
3910 Then_Statements => New_List (Stmt));
3911 end Build_Raise_Statement;
3913 -----------------------------
3914 -- Build_Record_Deep_Procs --
3915 -----------------------------
3917 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3921 (Prim => Initialize_Case,
3923 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3925 if not Is_Limited_View (Typ) then
3928 (Prim => Adjust_Case,
3930 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3933 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3934 -- suppressed since these routine will not be used.
3936 if not Restriction_Active (No_Finalization) then
3939 (Prim => Finalize_Case,
3941 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3943 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3945 if not CodePeer_Mode then
3948 (Prim => Address_Case,
3950 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3953 end Build_Record_Deep_Procs;
3959 function Cleanup_Array
3962 Typ : Entity_Id) return List_Id
3964 Loc : constant Source_Ptr := Sloc (N);
3965 Index_List : constant List_Id := New_List;
3967 function Free_Component return List_Id;
3968 -- Generate the code to finalize the task or protected subcomponents
3969 -- of a single component of the array.
3971 function Free_One_Dimension (Dim : Int) return List_Id;
3972 -- Generate a loop over one dimension of the array
3974 --------------------
3975 -- Free_Component --
3976 --------------------
3978 function Free_Component return List_Id is
3979 Stmts : List_Id := New_List;
3981 C_Typ : constant Entity_Id := Component_Type (Typ);
3984 -- Component type is known to contain tasks or protected objects
3987 Make_Indexed_Component (Loc,
3988 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3989 Expressions => Index_List);
3991 Set_Etype (Tsk, C_Typ);
3993 if Is_Task_Type (C_Typ) then
3994 Append_To (Stmts, Cleanup_Task (N, Tsk));
3996 elsif Is_Simple_Protected_Type (C_Typ) then
3997 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3999 elsif Is_Record_Type (C_Typ) then
4000 Stmts := Cleanup_Record (N, Tsk, C_Typ);
4002 elsif Is_Array_Type (C_Typ) then
4003 Stmts := Cleanup_Array (N, Tsk, C_Typ);
4009 ------------------------
4010 -- Free_One_Dimension --
4011 ------------------------
4013 function Free_One_Dimension (Dim : Int) return List_Id is
4017 if Dim > Number_Dimensions (Typ) then
4018 return Free_Component;
4020 -- Here we generate the required loop
4023 Index := Make_Temporary (Loc, 'J');
4024 Append (New_Occurrence_Of (Index, Loc), Index_List);
4027 Make_Implicit_Loop_Statement (N,
4028 Identifier => Empty,
4030 Make_Iteration_Scheme (Loc,
4031 Loop_Parameter_Specification =>
4032 Make_Loop_Parameter_Specification (Loc,
4033 Defining_Identifier => Index,
4034 Discrete_Subtype_Definition =>
4035 Make_Attribute_Reference (Loc,
4036 Prefix => Duplicate_Subexpr (Obj),
4037 Attribute_Name => Name_Range,
4038 Expressions => New_List (
4039 Make_Integer_Literal (Loc, Dim))))),
4040 Statements => Free_One_Dimension (Dim + 1)));
4042 end Free_One_Dimension;
4044 -- Start of processing for Cleanup_Array
4047 return Free_One_Dimension (1);
4050 --------------------
4051 -- Cleanup_Record --
4052 --------------------
4054 function Cleanup_Record
4057 Typ : Entity_Id) return List_Id
4059 Loc : constant Source_Ptr := Sloc (N);
4060 Stmts : constant List_Id := New_List;
4061 U_Typ : constant Entity_Id := Underlying_Type (Typ);
4067 if Has_Discriminants (U_Typ)
4068 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
4069 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
4072 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
4074 -- For now, do not attempt to free a component that may appear in a
4075 -- variant, and instead issue a warning. Doing this "properly" would
4076 -- require building a case statement and would be quite a mess. Note
4077 -- that the RM only requires that free "work" for the case of a task
4078 -- access value, so already we go way beyond this in that we deal
4079 -- with the array case and non-discriminated record cases.
4082 ("task/protected object in variant record will not be freed??", N);
4083 return New_List (Make_Null_Statement (Loc));
4086 Comp := First_Component (U_Typ);
4087 while Present (Comp) loop
4088 if Chars (Comp) /= Name_uParent
4089 and then (Has_Task (Etype (Comp))
4090 or else Has_Simple_Protected_Object (Etype (Comp)))
4093 Make_Selected_Component (Loc,
4094 Prefix => Duplicate_Subexpr_No_Checks (Obj),
4095 Selector_Name => New_Occurrence_Of (Comp, Loc));
4096 Set_Etype (Tsk, Etype (Comp));
4098 if Is_Task_Type (Etype (Comp)) then
4099 Append_To (Stmts, Cleanup_Task (N, Tsk));
4101 elsif Is_Simple_Protected_Type (Etype (Comp)) then
4102 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
4104 elsif Is_Record_Type (Etype (Comp)) then
4106 -- Recurse, by generating the prefix of the argument to the
4107 -- eventual cleanup call.
4109 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
4111 elsif Is_Array_Type (Etype (Comp)) then
4112 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
4116 Next_Component (Comp);
4122 ------------------------------
4123 -- Cleanup_Protected_Object --
4124 ------------------------------
4126 function Cleanup_Protected_Object
4128 Ref : Node_Id) return Node_Id
4130 Loc : constant Source_Ptr := Sloc (N);
4133 -- For restricted run-time libraries (Ravenscar), tasks are
4134 -- non-terminating, and protected objects can only appear at library
4135 -- level, so we do not want finalization of protected objects.
4137 if Restricted_Profile then
4142 Make_Procedure_Call_Statement (Loc,
4144 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
4145 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4147 end Cleanup_Protected_Object;
4153 function Cleanup_Task
4155 Ref : Node_Id) return Node_Id
4157 Loc : constant Source_Ptr := Sloc (N);
4160 -- For restricted run-time libraries (Ravenscar), tasks are
4161 -- non-terminating and they can only appear at library level,
4162 -- so we do not want finalization of task objects.
4164 if Restricted_Profile then
4169 Make_Procedure_Call_Statement (Loc,
4171 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
4172 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4176 --------------------------------------
4177 -- Check_Unnesting_Elaboration_Code --
4178 --------------------------------------
4180 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
4181 Loc : constant Source_Ptr := Sloc (N);
4182 Block_Elab_Proc : Entity_Id := Empty;
4184 procedure Set_Block_Elab_Proc;
4185 -- Create a defining identifier for a procedure that will replace
4186 -- a block with nested subprograms (unless it has already been created,
4187 -- in which case this is a no-op).
4189 procedure Set_Block_Elab_Proc is
4191 if No (Block_Elab_Proc) then
4192 Block_Elab_Proc := Make_Temporary (Loc, 'I');
4194 end Set_Block_Elab_Proc;
4196 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
4197 -- Find entities in the elaboration code of a library package body that
4198 -- contain or represent a subprogram body. A body can appear within a
4199 -- block or a loop or can appear by itself if generated for an object
4200 -- declaration that involves controlled actions. The first such entity
4201 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4202 -- that will be used to reset the scopes of all entities that become
4203 -- local to the new elaboration procedure. This is needed for subsequent
4204 -- unnesting actions, which depend on proper setting of the Scope links
4205 -- to determine the nesting level of each subprogram.
4207 -----------------------
4208 -- Find_Local_Scope --
4209 -----------------------
4211 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
4218 while Present (Stat) loop
4219 case Nkind (Stat) is
4220 when N_Block_Statement =>
4221 if Present (Identifier (Stat)) then
4222 Id := Entity (Identifier (Stat));
4224 -- The Scope of this block needs to be reset to the new
4225 -- procedure if the block contains nested subprograms.
4227 if Present (Id) and then Contains_Subprogram (Id) then
4228 Set_Block_Elab_Proc;
4229 Set_Scope (Id, Block_Elab_Proc);
4233 when N_Loop_Statement =>
4234 Id := Entity (Identifier (Stat));
4236 if Present (Id) and then Contains_Subprogram (Id) then
4237 if Scope (Id) = Current_Scope then
4238 Set_Block_Elab_Proc;
4239 Set_Scope (Id, Block_Elab_Proc);
4243 -- We traverse the loop's statements as well, which may
4244 -- include other block (etc.) statements that need to have
4245 -- their Scope set to Block_Elab_Proc. (Is this really the
4246 -- case, or do such nested blocks refer to the loop scope
4247 -- rather than the loop's enclosing scope???.)
4249 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
4251 when N_If_Statement =>
4252 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
4253 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
4255 Node := First (Elsif_Parts (Stat));
4256 while Present (Node) loop
4257 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node));
4261 when N_Case_Statement =>
4262 Node := First (Alternatives (Stat));
4263 while Present (Node) loop
4264 Reset_Scopes_To_Block_Elab_Proc (Statements (Node));
4268 -- Reset the Scope of a subprogram occurring at the top level
4270 when N_Subprogram_Body =>
4271 Id := Defining_Entity (Stat);
4273 Set_Block_Elab_Proc;
4274 Set_Scope (Id, Block_Elab_Proc);
4282 end Reset_Scopes_To_Block_Elab_Proc;
4286 H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4287 Elab_Body : Node_Id;
4288 Elab_Call : Node_Id;
4290 -- Start of processing for Check_Unnesting_Elaboration_Code
4293 if Present (H_Seq) then
4294 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
4296 -- There may be subprograms declared in the exception handlers
4297 -- of the current body.
4299 if Present (Exception_Handlers (H_Seq)) then
4301 Handler : Node_Id := First (Exception_Handlers (H_Seq));
4303 while Present (Handler) loop
4304 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
4311 if Present (Block_Elab_Proc) then
4313 Make_Subprogram_Body (Loc,
4315 Make_Procedure_Specification (Loc,
4316 Defining_Unit_Name => Block_Elab_Proc),
4317 Declarations => New_List,
4318 Handled_Statement_Sequence =>
4319 Relocate_Node (Handled_Statement_Sequence (N)));
4322 Make_Procedure_Call_Statement (Loc,
4323 Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
4325 Append_To (Declarations (N), Elab_Body);
4326 Analyze (Elab_Body);
4327 Set_Has_Nested_Subprogram (Block_Elab_Proc);
4329 Set_Handled_Statement_Sequence (N,
4330 Make_Handled_Sequence_Of_Statements (Loc,
4331 Statements => New_List (Elab_Call)));
4333 Analyze (Elab_Call);
4335 -- Could we reset the scopes of entities associated with the new
4336 -- procedure here via a loop over entities rather than doing it in
4337 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4340 end Check_Unnesting_Elaboration_Code;
4342 ---------------------------------------
4343 -- Check_Unnesting_In_Decls_Or_Stmts --
4344 ---------------------------------------
4346 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
4347 Decl_Or_Stmt : Node_Id;
4350 if Unnest_Subprogram_Mode
4351 and then Present (Decls_Or_Stmts)
4353 Decl_Or_Stmt := First (Decls_Or_Stmts);
4354 while Present (Decl_Or_Stmt) loop
4355 if Nkind (Decl_Or_Stmt) = N_Block_Statement
4356 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
4358 Unnest_Block (Decl_Or_Stmt);
4360 -- If-statements may contain subprogram bodies at the outer level
4361 -- of their statement lists, and the subprograms may make up-level
4362 -- references (such as to objects declared in the same statement
4363 -- list). Unlike block and loop cases, however, we don't have an
4364 -- entity on which to test the Contains_Subprogram flag, so
4365 -- Unnest_If_Statement must traverse the statement lists to
4366 -- determine whether there are nested subprograms present.
4368 elsif Nkind (Decl_Or_Stmt) = N_If_Statement then
4369 Unnest_If_Statement (Decl_Or_Stmt);
4371 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
4373 Id : constant Entity_Id :=
4374 Entity (Identifier (Decl_Or_Stmt));
4377 -- When a top-level loop within declarations of a library
4378 -- package spec or body contains nested subprograms, we wrap
4379 -- it in a procedure to handle possible up-level references
4380 -- to entities associated with the loop (such as loop
4383 if Present (Id) and then Contains_Subprogram (Id) then
4384 Unnest_Loop (Decl_Or_Stmt);
4388 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration
4389 and then not Modify_Tree_For_C
4391 Check_Unnesting_In_Decls_Or_Stmts
4392 (Visible_Declarations (Specification (Decl_Or_Stmt)));
4393 Check_Unnesting_In_Decls_Or_Stmts
4394 (Private_Declarations (Specification (Decl_Or_Stmt)));
4396 elsif Nkind (Decl_Or_Stmt) = N_Package_Body
4397 and then not Modify_Tree_For_C
4399 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
4400 if Present (Statements
4401 (Handled_Statement_Sequence (Decl_Or_Stmt)))
4403 Check_Unnesting_In_Decls_Or_Stmts (Statements
4404 (Handled_Statement_Sequence (Decl_Or_Stmt)));
4405 Check_Unnesting_In_Handlers (Decl_Or_Stmt);
4409 Next (Decl_Or_Stmt);
4412 end Check_Unnesting_In_Decls_Or_Stmts;
4414 ---------------------------------
4415 -- Check_Unnesting_In_Handlers --
4416 ---------------------------------
4418 procedure Check_Unnesting_In_Handlers (N : Node_Id) is
4419 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4422 if Present (Stmt_Seq)
4423 and then Present (Exception_Handlers (Stmt_Seq))
4426 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
4428 while Present (Handler) loop
4429 if Present (Statements (Handler)) then
4430 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
4437 end Check_Unnesting_In_Handlers;
4439 ------------------------------
4440 -- Check_Visibly_Controlled --
4441 ------------------------------
4443 procedure Check_Visibly_Controlled
4444 (Prim : Final_Primitives;
4446 E : in out Entity_Id;
4447 Cref : in out Node_Id)
4449 Parent_Type : Entity_Id;
4453 if Is_Derived_Type (Typ)
4454 and then Comes_From_Source (E)
4455 and then No (Overridden_Operation (E))
4457 -- We know that the explicit operation on the type does not override
4458 -- the inherited operation of the parent, and that the derivation
4459 -- is from a private type that is not visibly controlled.
4461 Parent_Type := Etype (Typ);
4462 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
4464 if Present (Op) then
4467 -- Wrap the object to be initialized into the proper
4468 -- unchecked conversion, to be compatible with the operation
4471 if Nkind (Cref) = N_Unchecked_Type_Conversion then
4472 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
4474 Cref := Unchecked_Convert_To (Parent_Type, Cref);
4478 end Check_Visibly_Controlled;
4480 --------------------------
4481 -- Contains_Subprogram --
4482 --------------------------
4484 function Contains_Subprogram (Blk : Entity_Id) return Boolean is
4488 E := First_Entity (Blk);
4490 while Present (E) loop
4491 if Is_Subprogram (E) then
4494 elsif Ekind (E) in E_Block | E_Loop
4495 and then Contains_Subprogram (E)
4504 end Contains_Subprogram;
4510 function Convert_View
4513 Ind : Pos := 1) return Node_Id
4515 Fent : Entity_Id := First_Entity (Proc);
4520 for J in 2 .. Ind loop
4524 Ftyp := Etype (Fent);
4526 if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
4527 Atyp := Entity (Subtype_Mark (Arg));
4529 Atyp := Etype (Arg);
4532 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
4533 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
4536 and then Present (Atyp)
4537 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
4538 and then Base_Type (Underlying_Type (Atyp)) =
4539 Base_Type (Underlying_Type (Ftyp))
4541 return Unchecked_Convert_To (Ftyp, Arg);
4543 -- If the argument is already a conversion, as generated by
4544 -- Make_Init_Call, set the target type to the type of the formal
4545 -- directly, to avoid spurious typing problems.
4547 elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion
4548 and then not Is_Class_Wide_Type (Atyp)
4550 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
4551 Set_Etype (Arg, Ftyp);
4554 -- Otherwise, introduce a conversion when the designated object
4555 -- has a type derived from the formal of the controlled routine.
4557 elsif Is_Private_Type (Ftyp)
4558 and then Present (Atyp)
4559 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
4561 return Unchecked_Convert_To (Ftyp, Arg);
4568 -------------------------------
4569 -- Establish_Transient_Scope --
4570 -------------------------------
4572 -- This procedure is called each time a transient block has to be inserted
4573 -- that is to say for each call to a function with unconstrained or tagged
4574 -- result. It creates a new scope on the scope stack in order to enclose
4575 -- all transient variables generated.
4577 procedure Establish_Transient_Scope
4579 Manage_Sec_Stack : Boolean)
4581 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
4582 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4584 function Find_Enclosing_Transient_Scope return Entity_Id;
4585 -- Examine the scope stack looking for the nearest enclosing transient
4586 -- scope within the innermost enclosing package or subprogram. Return
4587 -- Empty if no such scope exists.
4589 function Find_Transient_Context (N : Node_Id) return Node_Id;
4590 -- Locate a suitable context for arbitrary node N which may need to be
4591 -- serviced by a transient scope. Return Empty if no suitable context
4594 procedure Delegate_Sec_Stack_Management;
4595 -- Move the management of the secondary stack to the nearest enclosing
4598 procedure Create_Transient_Scope (Context : Node_Id);
4599 -- Place a new scope on the scope stack in order to service construct
4600 -- Context. Context is the node found by Find_Transient_Context. The
4601 -- new scope may also manage the secondary stack.
4603 ----------------------------
4604 -- Create_Transient_Scope --
4605 ----------------------------
4607 procedure Create_Transient_Scope (Context : Node_Id) is
4608 Loc : constant Source_Ptr := Sloc (N);
4610 Iter_Loop : Entity_Id;
4611 Trans_Scop : constant Entity_Id :=
4612 New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4615 Set_Etype (Trans_Scop, Standard_Void_Type);
4617 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4620 Push_Scope (Trans_Scop);
4621 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Context;
4622 Set_Scope_Is_Transient;
4624 -- The transient scope must also manage the secondary stack
4626 if Manage_Sec_Stack then
4627 Set_Uses_Sec_Stack (Trans_Scop);
4628 Check_Restriction (No_Secondary_Stack, N);
4630 -- The expansion of iterator loops generates references to objects
4631 -- in order to extract elements from a container:
4633 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4634 -- Obj : <object type> renames Ref.all.Element.all;
4636 -- These references are controlled and returned on the secondary
4637 -- stack. A new reference is created at each iteration of the loop
4638 -- and as a result it must be finalized and the space occupied by
4639 -- it on the secondary stack reclaimed at the end of the current
4642 -- When the context that requires a transient scope is a call to
4643 -- routine Reference, the node to be wrapped is the source object:
4645 -- for Obj of Container loop
4647 -- Routine Wrap_Transient_Declaration however does not generate
4648 -- a physical block as wrapping a declaration will kill it too
4649 -- early. To handle this peculiar case, mark the related iterator
4650 -- loop as requiring the secondary stack. This signals the
4651 -- finalization machinery to manage the secondary stack (see
4652 -- routine Process_Statements_For_Controlled_Objects).
4654 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
4656 if Present (Iter_Loop) then
4657 Set_Uses_Sec_Stack (Iter_Loop);
4661 if Debug_Flag_W then
4662 Write_Str (" <Transient>");
4665 end Create_Transient_Scope;
4667 -----------------------------------
4668 -- Delegate_Sec_Stack_Management --
4669 -----------------------------------
4671 procedure Delegate_Sec_Stack_Management is
4673 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4675 Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
4677 -- Prevent the search from going too far or within the scope
4678 -- space of another unit.
4680 if Scope.Entity = Standard_Standard then
4683 -- No transient scope should be encountered during the
4684 -- traversal because Establish_Transient_Scope should have
4685 -- already handled this case.
4687 elsif Scope.Is_Transient then
4688 raise Program_Error;
4690 -- The construct that requires secondary stack management is
4691 -- always enclosed by a package or subprogram scope.
4693 elsif Is_Package_Or_Subprogram (Scope.Entity) then
4694 Set_Uses_Sec_Stack (Scope.Entity);
4695 Check_Restriction (No_Secondary_Stack, N);
4702 -- At this point no suitable scope was found. This should never occur
4703 -- because a construct is always enclosed by a compilation unit which
4706 pragma Assert (False);
4707 end Delegate_Sec_Stack_Management;
4709 ------------------------------------
4710 -- Find_Enclosing_Transient_Scope --
4711 ------------------------------------
4713 function Find_Enclosing_Transient_Scope return Entity_Id is
4715 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4717 Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
4719 -- Prevent the search from going too far or within the scope
4720 -- space of another unit.
4722 if Scope.Entity = Standard_Standard
4723 or else Is_Package_Or_Subprogram (Scope.Entity)
4727 elsif Scope.Is_Transient then
4728 return Scope.Entity;
4734 end Find_Enclosing_Transient_Scope;
4736 ----------------------------
4737 -- Find_Transient_Context --
4738 ----------------------------
4740 function Find_Transient_Context (N : Node_Id) return Node_Id is
4741 Curr : Node_Id := N;
4742 Prev : Node_Id := Empty;
4745 while Present (Curr) loop
4746 case Nkind (Curr) is
4750 -- Declarations act as a boundary for a transient scope even if
4751 -- they are not wrapped, see Wrap_Transient_Declaration.
4753 when N_Object_Declaration
4754 | N_Object_Renaming_Declaration
4755 | N_Subtype_Declaration
4761 -- Statements and statement-like constructs act as a boundary
4762 -- for a transient scope.
4764 when N_Accept_Alternative
4765 | N_Attribute_Definition_Clause
4767 | N_Case_Statement_Alternative
4769 | N_Delay_Alternative
4770 | N_Delay_Until_Statement
4771 | N_Delay_Relative_Statement
4772 | N_Discriminant_Association
4774 | N_Entry_Body_Formal_Part
4777 | N_Iteration_Scheme
4778 | N_Terminate_Alternative
4780 pragma Assert (Present (Prev));
4783 when N_Assignment_Statement =>
4786 when N_Entry_Call_Statement
4787 | N_Procedure_Call_Statement
4789 -- When an entry or procedure call acts as the alternative
4790 -- of a conditional or timed entry call, the proper context
4791 -- is that of the alternative.
4793 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
4794 and then Nkind (Parent (Parent (Curr))) in
4795 N_Conditional_Entry_Call | N_Timed_Entry_Call
4797 return Parent (Parent (Curr));
4799 -- General case for entry or procedure calls
4807 -- Pragma Check is not a valid transient context in
4808 -- GNATprove mode because the pragma must remain unchanged.
4811 and then Get_Pragma_Id (Curr) = Pragma_Check
4815 -- General case for pragmas
4821 when N_Raise_Statement =>
4824 when N_Simple_Return_Statement =>
4826 -- A return statement is not a valid transient context when
4827 -- the function itself requires transient scope management
4828 -- because the result will be reclaimed too early.
4830 if Requires_Transient_Scope (Etype
4831 (Return_Applies_To (Return_Statement_Entity (Curr))))
4835 -- General case for return statements
4843 when N_Attribute_Reference =>
4844 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
4848 -- An Ada 2012 iterator specification is not a valid context
4849 -- because Analyze_Iterator_Specification already employs
4850 -- special processing for it.
4852 when N_Iterator_Specification =>
4855 when N_Loop_Parameter_Specification =>
4857 -- An iteration scheme is not a valid context because
4858 -- routine Analyze_Iteration_Scheme already employs
4859 -- special processing.
4861 if Nkind (Parent (Curr)) = N_Iteration_Scheme then
4864 return Parent (Curr);
4869 -- The following nodes represent "dummy contexts" which do not
4870 -- need to be wrapped.
4872 when N_Component_Declaration
4873 | N_Discriminant_Specification
4874 | N_Parameter_Specification
4878 -- If the traversal leaves a scope without having been able to
4879 -- find a construct to wrap, something is going wrong, but this
4880 -- can happen in error situations that are not detected yet
4881 -- (such as a dynamic string in a pragma Export).
4883 when N_Block_Statement
4886 | N_Package_Declaration
4900 Curr := Parent (Curr);
4904 end Find_Transient_Context;
4906 ------------------------------
4907 -- Is_Package_Or_Subprogram --
4908 ------------------------------
4910 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
4912 return Ekind (Id) in E_Entry
4917 | E_Subprogram_Body;
4918 end Is_Package_Or_Subprogram;
4922 Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
4925 -- Start of processing for Establish_Transient_Scope
4928 -- Do not create a new transient scope if there is already an enclosing
4929 -- transient scope within the innermost enclosing package or subprogram.
4931 if Present (Trans_Id) then
4933 -- If the transient scope was requested for purposes of managing the
4934 -- secondary stack, then the existing scope must perform this task.
4936 if Manage_Sec_Stack then
4937 Set_Uses_Sec_Stack (Trans_Id);
4943 -- Find the construct that must be serviced by a new transient scope, if
4946 Context := Find_Transient_Context (N);
4948 if Present (Context) then
4949 if Nkind (Context) = N_Assignment_Statement then
4951 -- An assignment statement with suppressed controlled semantics
4952 -- does not need a transient scope because finalization is not
4953 -- desirable at this point. Note that No_Ctrl_Actions is also
4954 -- set for non-controlled assignments to suppress dispatching
4957 if No_Ctrl_Actions (Context)
4958 and then Needs_Finalization (Etype (Name (Context)))
4960 -- When a controlled component is initialized by a function
4961 -- call, the result on the secondary stack is always assigned
4962 -- to the component. Signal the nearest suitable scope that it
4963 -- is safe to manage the secondary stack.
4965 if Manage_Sec_Stack and then Within_Init_Proc then
4966 Delegate_Sec_Stack_Management;
4969 -- Otherwise the assignment is a normal transient context and thus
4970 -- requires a transient scope.
4973 Create_Transient_Scope (Context);
4979 Create_Transient_Scope (Context);
4982 end Establish_Transient_Scope;
4984 ----------------------------
4985 -- Expand_Cleanup_Actions --
4986 ----------------------------
4988 procedure Expand_Cleanup_Actions (N : Node_Id) is
4990 (Nkind (N) in N_Block_Statement
4994 | N_Extended_Return_Statement);
4996 Scop : constant Entity_Id := Current_Scope;
4998 Is_Asynchronous_Call : constant Boolean :=
4999 Nkind (N) = N_Block_Statement
5000 and then Is_Asynchronous_Call_Block (N);
5001 Is_Master : constant Boolean :=
5002 Nkind (N) /= N_Extended_Return_Statement
5003 and then Nkind (N) /= N_Entry_Body
5004 and then Is_Task_Master (N);
5005 Is_Protected_Subp_Body : constant Boolean :=
5006 Nkind (N) = N_Subprogram_Body
5007 and then Is_Protected_Subprogram_Body (N);
5008 Is_Task_Allocation : constant Boolean :=
5009 Nkind (N) = N_Block_Statement
5010 and then Is_Task_Allocation_Block (N);
5011 Is_Task_Body : constant Boolean :=
5012 Nkind (Original_Node (N)) = N_Task_Body;
5014 -- We mark the secondary stack if it is used in this construct, and
5015 -- we're not returning a function result on the secondary stack, except
5016 -- that a build-in-place function that might or might not return on the
5017 -- secondary stack always needs a mark. A run-time test is required in
5018 -- the case where the build-in-place function has a BIP_Alloc extra
5019 -- parameter (see Create_Finalizer).
5021 Needs_Sec_Stack_Mark : constant Boolean :=
5022 (Uses_Sec_Stack (Scop)
5024 not Sec_Stack_Needed_For_Return (Scop))
5026 (Is_Build_In_Place_Function (Scop)
5027 and then Needs_BIP_Alloc_Form (Scop));
5029 Needs_Custom_Cleanup : constant Boolean :=
5030 Nkind (N) = N_Block_Statement
5031 and then Present (Cleanup_Actions (N));
5033 Actions_Required : constant Boolean :=
5034 Requires_Cleanup_Actions (N, True)
5035 or else Is_Asynchronous_Call
5037 or else Is_Protected_Subp_Body
5038 or else Is_Task_Allocation
5039 or else Is_Task_Body
5040 or else Needs_Sec_Stack_Mark
5041 or else Needs_Custom_Cleanup;
5046 -- Start of processing for Expand_Cleanup_Actions
5049 -- The current construct does not need any form of servicing
5051 if not Actions_Required then
5054 -- If the current node is a rewritten task body and the descriptors have
5055 -- not been delayed (due to some nested instantiations), do not generate
5056 -- redundant cleanup actions.
5059 and then Nkind (N) = N_Subprogram_Body
5060 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
5065 -- If an extended return statement contains something like
5069 -- where F is a build-in-place function call returning a controlled
5070 -- type, then a temporary object will be implicitly declared as part
5071 -- of the statement list, and this will need cleanup. In such cases,
5074 -- return Result : T := ... do
5075 -- <statements> -- possibly with handlers
5080 -- return Result : T := ... do
5081 -- declare -- no declarations
5083 -- <statements> -- possibly with handlers
5084 -- end; -- no handlers
5087 -- So Expand_Cleanup_Actions will end up being called recursively on the
5090 if Nkind (N) = N_Extended_Return_Statement then
5092 Block : constant Node_Id :=
5093 Make_Block_Statement (Sloc (N),
5094 Declarations => Empty_List,
5095 Handled_Statement_Sequence =>
5096 Handled_Statement_Sequence (N));
5098 Set_Handled_Statement_Sequence (N,
5099 Make_Handled_Sequence_Of_Statements (Sloc (N),
5100 Statements => New_List (Block)));
5105 -- Analysis of the block did all the work
5110 if Needs_Custom_Cleanup then
5111 Cln := Cleanup_Actions (N);
5116 if No (Declarations (N)) then
5117 Set_Declarations (N, New_List);
5121 Decls : constant List_Id := Declarations (N);
5123 Mark : Entity_Id := Empty;
5125 -- If we are generating expanded code for debugging purposes, use the
5126 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5127 -- be updated subsequently to reference the proper line in .dg files.
5128 -- If we are not debugging generated code, use No_Location instead,
5129 -- so that no debug information is generated for the cleanup code.
5130 -- This makes the behavior of the NEXT command in GDB monotonic, and
5131 -- makes the placement of breakpoints more accurate.
5133 if Debug_Generated_Code then
5139 -- A task activation call has already been built for a task
5140 -- allocation block.
5142 if not Is_Task_Allocation then
5143 Build_Task_Activation_Call (N);
5147 Establish_Task_Master (N);
5150 -- If secondary stack is in use, generate:
5152 -- Mnn : constant Mark_Id := SS_Mark;
5154 if Needs_Sec_Stack_Mark then
5155 Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks
5156 Mark := Make_Temporary (Loc, 'M');
5159 Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark);
5161 Prepend_To (Decls, Mark_Call);
5162 Analyze (Mark_Call);
5166 -- Generate finalization calls for all controlled objects appearing
5167 -- in the statements of N. Add context specific cleanup for various
5172 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
5175 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
5179 if Present (Fin_Id) then
5180 Build_Finalizer_Call (N, Fin_Id);
5183 end Expand_Cleanup_Actions;
5185 ---------------------------
5186 -- Expand_N_Package_Body --
5187 ---------------------------
5189 -- Add call to Activate_Tasks if body is an activator (actual processing
5190 -- is in chapter 9).
5192 -- Generate subprogram descriptor for elaboration routine
5194 -- Encode entity names in package body
5196 procedure Expand_N_Package_Body (N : Node_Id) is
5197 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
5201 -- This is done only for non-generic packages
5203 if Ekind (Spec_Id) = E_Package then
5204 -- Build dispatch tables of library-level tagged types for bodies
5205 -- that are not compilation units (see Analyze_Compilation_Unit),
5206 -- except for instances because they have no N_Compilation_Unit.
5208 if Tagged_Type_Expansion
5209 and then Is_Library_Level_Entity (Spec_Id)
5210 and then (not Is_Compilation_Unit (Spec_Id)
5211 or else Is_Generic_Instance (Spec_Id))
5213 Build_Static_Dispatch_Tables (N);
5216 Push_Scope (Spec_Id);
5218 Expand_CUDA_Package (N);
5220 Build_Task_Activation_Call (N);
5222 -- Verify the run-time semantics of pragma Initial_Condition at the
5223 -- end of the body statements.
5225 Expand_Pragma_Initial_Condition (Spec_Id, N);
5227 -- If this is a library-level package and unnesting is enabled,
5228 -- check for the presence of blocks with nested subprograms occurring
5229 -- in elaboration code, and generate procedures to encapsulate the
5230 -- blocks in case the nested subprograms make up-level references.
5232 if Unnest_Subprogram_Mode
5234 Is_Library_Level_Entity (Current_Scope)
5236 Check_Unnesting_Elaboration_Code (N);
5237 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
5238 Check_Unnesting_In_Handlers (N);
5244 Set_Elaboration_Flag (N, Spec_Id);
5245 Set_In_Package_Body (Spec_Id, False);
5247 -- Set to encode entity names in package body before gigi is called
5249 Qualify_Entity_Names (N);
5251 if Ekind (Spec_Id) /= E_Generic_Package then
5254 Clean_Stmts => No_List,
5256 Top_Decls => No_List,
5257 Defer_Abort => False,
5260 if Present (Fin_Id) then
5262 Body_Ent : Node_Id := Defining_Unit_Name (N);
5265 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
5266 Body_Ent := Defining_Identifier (Body_Ent);
5269 Set_Finalizer (Body_Ent, Fin_Id);
5273 end Expand_N_Package_Body;
5275 ----------------------------------
5276 -- Expand_N_Package_Declaration --
5277 ----------------------------------
5279 -- Add call to Activate_Tasks if there are tasks declared and the package
5280 -- has no body. Note that in Ada 83 this may result in premature activation
5281 -- of some tasks, given that we cannot tell whether a body will eventually
5284 procedure Expand_N_Package_Declaration (N : Node_Id) is
5285 Id : constant Entity_Id := Defining_Entity (N);
5286 Spec : constant Node_Id := Specification (N);
5290 No_Body : Boolean := False;
5291 -- True in the case of a package declaration that is a compilation
5292 -- unit and for which no associated body will be compiled in this
5296 -- Case of a package declaration other than a compilation unit
5298 if Nkind (Parent (N)) /= N_Compilation_Unit then
5301 -- Case of a compilation unit that does not require a body
5303 elsif not Body_Required (Parent (N))
5304 and then not Unit_Requires_Body (Id)
5308 -- Special case of generating calling stubs for a remote call interface
5309 -- package: even though the package declaration requires one, the body
5310 -- won't be processed in this compilation (so any stubs for RACWs
5311 -- declared in the package must be generated here, along with the spec).
5313 elsif Parent (N) = Cunit (Main_Unit)
5314 and then Is_Remote_Call_Interface (Id)
5315 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
5320 -- For a nested instance, delay processing until freeze point
5322 if Has_Delayed_Freeze (Id)
5323 and then Nkind (Parent (N)) /= N_Compilation_Unit
5328 -- For a package declaration that implies no associated body, generate
5329 -- task activation call and RACW supporting bodies now (since we won't
5330 -- have a specific separate compilation unit for that).
5335 -- Generate RACW subprogram bodies
5337 if Has_RACW (Id) then
5338 Decls := Private_Declarations (Spec);
5341 Decls := Visible_Declarations (Spec);
5346 Set_Visible_Declarations (Spec, Decls);
5349 Append_RACW_Bodies (Decls, Id);
5350 Analyze_List (Decls);
5353 -- Generate task activation call as last step of elaboration
5355 if Present (Activation_Chain_Entity (N)) then
5356 Build_Task_Activation_Call (N);
5359 -- Verify the run-time semantics of pragma Initial_Condition at the
5360 -- end of the private declarations when the package lacks a body.
5362 Expand_Pragma_Initial_Condition (Id, N);
5367 -- Build dispatch tables of library-level tagged types for instances
5368 -- that are not compilation units (see Analyze_Compilation_Unit).
5370 if Tagged_Type_Expansion
5371 and then Is_Library_Level_Entity (Id)
5372 and then Is_Generic_Instance (Id)
5373 and then not Is_Compilation_Unit (Id)
5375 Build_Static_Dispatch_Tables (N);
5378 -- Note: it is not necessary to worry about generating a subprogram
5379 -- descriptor, since the only way to get exception handlers into a
5380 -- package spec is to include instantiations, and that would cause
5381 -- generation of subprogram descriptors to be delayed in any case.
5383 -- Set to encode entity names in package spec before gigi is called
5385 Qualify_Entity_Names (N);
5387 if Ekind (Id) /= E_Generic_Package then
5390 Clean_Stmts => No_List,
5392 Top_Decls => No_List,
5393 Defer_Abort => False,
5396 Set_Finalizer (Id, Fin_Id);
5399 -- If this is a library-level package and unnesting is enabled,
5400 -- check for the presence of blocks with nested subprograms occurring
5401 -- in elaboration code, and generate procedures to encapsulate the
5402 -- blocks in case the nested subprograms make up-level references.
5404 if Unnest_Subprogram_Mode
5405 and then Is_Library_Level_Entity (Current_Scope)
5407 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
5408 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
5410 end Expand_N_Package_Declaration;
5412 ---------------------------------
5413 -- Has_Simple_Protected_Object --
5414 ---------------------------------
5416 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
5418 if Has_Task (T) then
5421 elsif Is_Simple_Protected_Type (T) then
5424 elsif Is_Array_Type (T) then
5425 return Has_Simple_Protected_Object (Component_Type (T));
5427 elsif Is_Record_Type (T) then
5432 Comp := First_Component (T);
5433 while Present (Comp) loop
5434 if Has_Simple_Protected_Object (Etype (Comp)) then
5438 Next_Component (Comp);
5447 end Has_Simple_Protected_Object;
5449 ------------------------------------
5450 -- Insert_Actions_In_Scope_Around --
5451 ------------------------------------
5453 procedure Insert_Actions_In_Scope_Around
5456 Manage_SS : Boolean)
5458 Act_Before : constant List_Id :=
5459 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
5460 Act_After : constant List_Id :=
5461 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
5462 Act_Cleanup : constant List_Id :=
5463 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
5464 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5465 -- Last), but this was incorrect as Process_Transients_In_Scope may
5466 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5468 procedure Process_Transients_In_Scope
5469 (First_Object : Node_Id;
5470 Last_Object : Node_Id;
5471 Related_Node : Node_Id);
5472 -- Find all transient objects in the list First_Object .. Last_Object
5473 -- and generate finalization actions for them. Related_Node denotes the
5474 -- node which created all transient objects.
5476 ---------------------------------
5477 -- Process_Transients_In_Scope --
5478 ---------------------------------
5480 procedure Process_Transients_In_Scope
5481 (First_Object : Node_Id;
5482 Last_Object : Node_Id;
5483 Related_Node : Node_Id)
5485 Must_Hook : Boolean;
5486 -- Flag denoting whether the context requires transient object
5487 -- export to the outer finalizer.
5489 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
5490 -- Return Abandon if arbitrary node denotes a subprogram call
5492 function Has_Subprogram_Call is
5493 new Traverse_Func (Is_Subprogram_Call);
5495 procedure Process_Transient_In_Scope
5496 (Obj_Decl : Node_Id;
5497 Blk_Data : Finalization_Exception_Data;
5498 Blk_Stmts : List_Id);
5499 -- Generate finalization actions for a single transient object
5500 -- denoted by object declaration Obj_Decl. Blk_Data is the
5501 -- exception data of the enclosing block. Blk_Stmts denotes the
5502 -- statements of the enclosing block.
5504 ------------------------
5505 -- Is_Subprogram_Call --
5506 ------------------------
5508 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
5510 -- A regular procedure or function call
5512 if Nkind (N) in N_Subprogram_Call then
5517 -- Heavy expansion may relocate function calls outside the related
5518 -- node. Inspect the original node to detect the initial placement
5521 elsif Is_Rewrite_Substitution (N) then
5522 return Has_Subprogram_Call (Original_Node (N));
5524 -- Generalized indexing always involves a function call
5526 elsif Nkind (N) = N_Indexed_Component
5527 and then Present (Generalized_Indexing (N))
5536 end Is_Subprogram_Call;
5538 --------------------------------
5539 -- Process_Transient_In_Scope --
5540 --------------------------------
5542 procedure Process_Transient_In_Scope
5543 (Obj_Decl : Node_Id;
5544 Blk_Data : Finalization_Exception_Data;
5545 Blk_Stmts : List_Id)
5547 Loc : constant Source_Ptr := Sloc (Obj_Decl);
5548 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
5550 Fin_Stmts : List_Id;
5551 Hook_Assign : Node_Id;
5552 Hook_Clear : Node_Id;
5553 Hook_Decl : Node_Id;
5554 Hook_Insert : Node_Id;
5558 -- Mark the transient object as successfully processed to avoid
5559 -- double finalization.
5561 Set_Is_Finalized_Transient (Obj_Id);
5563 -- Construct all the pieces necessary to hook and finalize the
5564 -- transient object.
5566 Build_Transient_Object_Statements
5567 (Obj_Decl => Obj_Decl,
5568 Fin_Call => Fin_Call,
5569 Hook_Assign => Hook_Assign,
5570 Hook_Clear => Hook_Clear,
5571 Hook_Decl => Hook_Decl,
5572 Ptr_Decl => Ptr_Decl);
5574 -- The context contains at least one subprogram call which may
5575 -- raise an exception. This scenario employs "hooking" to pass
5576 -- transient objects to the enclosing finalizer in case of an
5581 -- Add the access type which provides a reference to the
5582 -- transient object. Generate:
5584 -- type Ptr_Typ is access all Desig_Typ;
5586 Insert_Action (Obj_Decl, Ptr_Decl);
5588 -- Add the temporary which acts as a hook to the transient
5589 -- object. Generate:
5591 -- Hook : Ptr_Typ := null;
5593 Insert_Action (Obj_Decl, Hook_Decl);
5595 -- When the transient object is initialized by an aggregate,
5596 -- the hook must capture the object after the last aggregate
5597 -- assignment takes place. Only then is the object considered
5598 -- fully initialized. Generate:
5600 -- Hook := Ptr_Typ (Obj_Id);
5602 -- Hook := Obj_Id'Unrestricted_Access;
5604 -- Similarly if we have a build in place call: we must
5605 -- initialize Hook only after the call has happened, otherwise
5606 -- Obj_Id will not be initialized yet.
5608 if Ekind (Obj_Id) in E_Constant | E_Variable then
5609 if Present (Last_Aggregate_Assignment (Obj_Id)) then
5610 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
5611 elsif Present (BIP_Initialization_Call (Obj_Id)) then
5612 Hook_Insert := BIP_Initialization_Call (Obj_Id);
5614 Hook_Insert := Obj_Decl;
5617 -- Otherwise the hook seizes the related object immediately
5620 Hook_Insert := Obj_Decl;
5623 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
5626 -- When exception propagation is enabled wrap the hook clear
5627 -- statement and the finalization call into a block to catch
5628 -- potential exceptions raised during finalization. Generate:
5632 -- [Deep_]Finalize (Obj_Ref);
5636 -- if not Raised then
5639 -- (Enn, Get_Current_Excep.all.all);
5643 if Exceptions_OK then
5644 Fin_Stmts := New_List;
5647 Append_To (Fin_Stmts, Hook_Clear);
5650 Append_To (Fin_Stmts, Fin_Call);
5652 Prepend_To (Blk_Stmts,
5653 Make_Block_Statement (Loc,
5654 Handled_Statement_Sequence =>
5655 Make_Handled_Sequence_Of_Statements (Loc,
5656 Statements => Fin_Stmts,
5657 Exception_Handlers => New_List (
5658 Build_Exception_Handler (Blk_Data)))));
5660 -- Otherwise generate:
5663 -- [Deep_]Finalize (Obj_Ref);
5665 -- Note that the statements are inserted in reverse order to
5666 -- achieve the desired final order outlined above.
5669 Prepend_To (Blk_Stmts, Fin_Call);
5672 Prepend_To (Blk_Stmts, Hook_Clear);
5675 end Process_Transient_In_Scope;
5679 Built : Boolean := False;
5680 Blk_Data : Finalization_Exception_Data;
5681 Blk_Decl : Node_Id := Empty;
5682 Blk_Decls : List_Id := No_List;
5684 Blk_Stmts : List_Id := No_List;
5685 Loc : Source_Ptr := No_Location;
5688 -- Start of processing for Process_Transients_In_Scope
5691 -- The expansion performed by this routine is as follows:
5693 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5694 -- Hook_1 : Ptr_Typ_1 := null;
5695 -- Ctrl_Trans_Obj_1 : ...;
5696 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5698 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5699 -- Hook_N : Ptr_Typ_N := null;
5700 -- Ctrl_Trans_Obj_N : ...;
5701 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5704 -- Abrt : constant Boolean := ...;
5705 -- Ex : Exception_Occurrence;
5706 -- Raised : Boolean := False;
5713 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5717 -- if not Raised then
5719 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5724 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5728 -- if not Raised then
5730 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5735 -- if Raised and not Abrt then
5736 -- Raise_From_Controlled_Operation (Ex);
5740 -- Recognize a scenario where the transient context is an object
5741 -- declaration initialized by a build-in-place function call:
5743 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5745 -- The rough expansion of the above is:
5747 -- Temp : ... := Ctrl_Func_Call;
5749 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5751 -- The finalization of any transient object must happen after the
5752 -- build-in-place function call is executed.
5754 if Nkind (N) = N_Object_Declaration
5755 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
5758 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
5760 -- Search the context for at least one subprogram call. If found, the
5761 -- machinery exports all transient objects to the enclosing finalizer
5762 -- due to the possibility of abnormal call termination.
5765 Must_Hook := Has_Subprogram_Call (N) = Abandon;
5766 Blk_Ins := Last_Object;
5770 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
5773 -- Examine all objects in the list First_Object .. Last_Object
5775 Obj_Decl := First_Object;
5776 while Present (Obj_Decl) loop
5777 if Nkind (Obj_Decl) = N_Object_Declaration
5778 and then Analyzed (Obj_Decl)
5779 and then Is_Finalizable_Transient (Obj_Decl, N)
5781 -- Do not process the node to be wrapped since it will be
5782 -- handled by the enclosing finalizer.
5784 and then Obj_Decl /= Related_Node
5786 Loc := Sloc (Obj_Decl);
5788 -- Before generating the cleanup code for the first transient
5789 -- object, create a wrapper block which houses all hook clear
5790 -- statements and finalization calls. This wrapper is needed by
5795 Blk_Stmts := New_List;
5798 -- Abrt : constant Boolean := ...;
5799 -- Ex : Exception_Occurrence;
5800 -- Raised : Boolean := False;
5802 if Exceptions_OK then
5803 Blk_Decls := New_List;
5804 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
5808 Make_Block_Statement (Loc,
5809 Declarations => Blk_Decls,
5810 Handled_Statement_Sequence =>
5811 Make_Handled_Sequence_Of_Statements (Loc,
5812 Statements => Blk_Stmts));
5815 -- Construct all necessary circuitry to hook and finalize a
5816 -- single transient object.
5818 pragma Assert (Present (Blk_Stmts));
5819 Process_Transient_In_Scope
5820 (Obj_Decl => Obj_Decl,
5821 Blk_Data => Blk_Data,
5822 Blk_Stmts => Blk_Stmts);
5825 -- Terminate the scan after the last object has been processed to
5826 -- avoid touching unrelated code.
5828 if Obj_Decl = Last_Object then
5835 -- Complete the decoration of the enclosing finalization block and
5836 -- insert it into the tree.
5838 if Present (Blk_Decl) then
5840 pragma Assert (Present (Blk_Stmts));
5841 pragma Assert (Loc /= No_Location);
5843 -- Note that this Abort_Undefer does not require a extra block or
5844 -- an AT_END handler because each finalization exception is caught
5845 -- in its own corresponding finalization block. As a result, the
5846 -- call to Abort_Defer always takes place.
5848 if Abort_Allowed then
5849 Prepend_To (Blk_Stmts,
5850 Build_Runtime_Call (Loc, RE_Abort_Defer));
5852 Append_To (Blk_Stmts,
5853 Build_Runtime_Call (Loc, RE_Abort_Undefer));
5857 -- if Raised and then not Abrt then
5858 -- Raise_From_Controlled_Operation (Ex);
5861 if Exceptions_OK then
5862 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
5865 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
5867 end Process_Transients_In_Scope;
5871 Loc : constant Source_Ptr := Sloc (N);
5872 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
5873 First_Obj : Node_Id;
5875 Mark_Id : Entity_Id;
5878 -- Start of processing for Insert_Actions_In_Scope_Around
5881 -- Nothing to do if the scope does not manage the secondary stack or
5882 -- does not contain meaningful actions for insertion.
5885 and then No (Act_Before)
5886 and then No (Act_After)
5887 and then No (Act_Cleanup)
5892 -- If the node to be wrapped is the trigger of an asynchronous select,
5893 -- it is not part of a statement list. The actions must be inserted
5894 -- before the select itself, which is part of some list of statements.
5895 -- Note that the triggering alternative includes the triggering
5896 -- statement and an optional statement list. If the node to be
5897 -- wrapped is part of that list, the normal insertion applies.
5899 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
5900 and then not Is_List_Member (Node_To_Wrap)
5902 Target := Parent (Parent (Node_To_Wrap));
5907 First_Obj := Target;
5910 -- Add all actions associated with a transient scope into the main tree.
5911 -- There are several scenarios here:
5913 -- +--- Before ----+ +----- After ---+
5914 -- 1) First_Obj ....... Target ........ Last_Obj
5916 -- 2) First_Obj ....... Target
5918 -- 3) Target ........ Last_Obj
5920 -- Flag declarations are inserted before the first object
5922 if Present (Act_Before) then
5923 First_Obj := First (Act_Before);
5924 Insert_List_Before (Target, Act_Before);
5927 -- Finalization calls are inserted after the last object
5929 if Present (Act_After) then
5930 Last_Obj := Last (Act_After);
5931 Insert_List_After (Target, Act_After);
5934 -- Mark and release the secondary stack when the context warrants it
5937 Mark_Id := Make_Temporary (Loc, 'M');
5940 -- Mnn : constant Mark_Id := SS_Mark;
5942 Insert_Before_And_Analyze
5943 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
5946 -- SS_Release (Mnn);
5948 Insert_After_And_Analyze
5949 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
5952 -- Check for transient objects associated with Target and generate the
5953 -- appropriate finalization actions for them.
5955 Process_Transients_In_Scope
5956 (First_Object => First_Obj,
5957 Last_Object => Last_Obj,
5958 Related_Node => Target);
5960 -- Reset the action lists
5963 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
5965 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
5969 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
5971 end Insert_Actions_In_Scope_Around;
5973 ------------------------------
5974 -- Is_Simple_Protected_Type --
5975 ------------------------------
5977 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
5980 Is_Protected_Type (T)
5981 and then not Uses_Lock_Free (T)
5982 and then not Has_Entries (T)
5983 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
5984 end Is_Simple_Protected_Type;
5986 -----------------------
5987 -- Make_Adjust_Call --
5988 -----------------------
5990 function Make_Adjust_Call
5993 Skip_Self : Boolean := False) return Node_Id
5995 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5996 Adj_Id : Entity_Id := Empty;
6003 -- Recover the proper type which contains Deep_Adjust
6005 if Is_Class_Wide_Type (Typ) then
6006 Utyp := Root_Type (Typ);
6011 Utyp := Underlying_Type (Base_Type (Utyp));
6012 Set_Assignment_OK (Ref);
6014 -- Deal with untagged derivation of private views
6016 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
6017 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6018 Ref := Unchecked_Convert_To (Utyp, Ref);
6019 Set_Assignment_OK (Ref);
6022 -- When dealing with the completion of a private type, use the base
6025 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
6026 pragma Assert (Is_Private_Type (Typ));
6028 Utyp := Base_Type (Utyp);
6029 Ref := Unchecked_Convert_To (Utyp, Ref);
6032 -- The underlying type may not be present due to a missing full view. In
6033 -- this case freezing did not take place and there is no [Deep_]Adjust
6034 -- primitive to call.
6039 elsif Skip_Self then
6040 if Has_Controlled_Component (Utyp) then
6041 if Is_Tagged_Type (Utyp) then
6042 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6044 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6048 -- Class-wide types, interfaces and types with controlled components
6050 elsif Is_Class_Wide_Type (Typ)
6051 or else Is_Interface (Typ)
6052 or else Has_Controlled_Component (Utyp)
6054 if Is_Tagged_Type (Utyp) then
6055 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6057 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6060 -- Derivations from [Limited_]Controlled
6062 elsif Is_Controlled (Utyp) then
6063 if Has_Controlled_Component (Utyp) then
6064 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6066 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
6071 elsif Is_Tagged_Type (Utyp) then
6072 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6075 raise Program_Error;
6078 if Present (Adj_Id) then
6080 -- If the object is unanalyzed, set its expected type for use in
6081 -- Convert_View in case an additional conversion is needed.
6084 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
6086 Set_Etype (Ref, Typ);
6089 -- The object reference may need another conversion depending on the
6090 -- type of the formal and that of the actual.
6092 if not Is_Class_Wide_Type (Typ) then
6093 Ref := Convert_View (Adj_Id, Ref);
6100 Skip_Self => Skip_Self);
6104 end Make_Adjust_Call;
6112 Proc_Id : Entity_Id;
6114 Skip_Self : Boolean := False) return Node_Id
6116 Params : constant List_Id := New_List (Param);
6119 -- Do not apply the controlled action to the object itself by signaling
6120 -- the related routine to avoid self.
6123 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
6127 Make_Procedure_Call_Statement (Loc,
6128 Name => New_Occurrence_Of (Proc_Id, Loc),
6129 Parameter_Associations => Params);
6132 --------------------------
6133 -- Make_Deep_Array_Body --
6134 --------------------------
6136 function Make_Deep_Array_Body
6137 (Prim : Final_Primitives;
6138 Typ : Entity_Id) return List_Id
6140 function Build_Adjust_Or_Finalize_Statements
6141 (Typ : Entity_Id) return List_Id;
6142 -- Create the statements necessary to adjust or finalize an array of
6143 -- controlled elements. Generate:
6146 -- Abort : constant Boolean := Triggered_By_Abort;
6148 -- Abort : constant Boolean := False; -- no abort
6150 -- E : Exception_Occurrence;
6151 -- Raised : Boolean := False;
6154 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6155 -- ^-- in the finalization case
6157 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6159 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6163 -- if not Raised then
6165 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6172 -- if Raised and then not Abort then
6173 -- Raise_From_Controlled_Operation (E);
6177 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
6178 -- Create the statements necessary to initialize an array of controlled
6179 -- elements. Include a mechanism to carry out partial finalization if an
6180 -- exception occurs. Generate:
6183 -- Counter : Integer := 0;
6186 -- for J1 in V'Range (1) loop
6188 -- for JN in V'Range (N) loop
6190 -- [Deep_]Initialize (V (J1, ..., JN));
6192 -- Counter := Counter + 1;
6197 -- Abort : constant Boolean := Triggered_By_Abort;
6199 -- Abort : constant Boolean := False; -- no abort
6200 -- E : Exception_Occurrence;
6201 -- Raised : Boolean := False;
6208 -- V'Length (N) - Counter;
6210 -- for F1 in reverse V'Range (1) loop
6212 -- for FN in reverse V'Range (N) loop
6213 -- if Counter > 0 then
6214 -- Counter := Counter - 1;
6217 -- [Deep_]Finalize (V (F1, ..., FN));
6221 -- if not Raised then
6223 -- Save_Occurrence (E,
6224 -- Get_Current_Excep.all.all);
6233 -- if Raised and then not Abort then
6234 -- Raise_From_Controlled_Operation (E);
6243 function New_References_To
6245 Loc : Source_Ptr) return List_Id;
6246 -- Given a list of defining identifiers, return a list of references to
6247 -- the original identifiers, in the same order as they appear.
6249 -----------------------------------------
6250 -- Build_Adjust_Or_Finalize_Statements --
6251 -----------------------------------------
6253 function Build_Adjust_Or_Finalize_Statements
6254 (Typ : Entity_Id) return List_Id
6256 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6257 Index_List : constant List_Id := New_List;
6258 Loc : constant Source_Ptr := Sloc (Typ);
6259 Num_Dims : constant Int := Number_Dimensions (Typ);
6261 procedure Build_Indexes;
6262 -- Generate the indexes used in the dimension loops
6268 procedure Build_Indexes is
6270 -- Generate the following identifiers:
6271 -- Jnn - for initialization
6273 for Dim in 1 .. Num_Dims loop
6274 Append_To (Index_List,
6275 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6281 Final_Decls : List_Id := No_List;
6282 Final_Data : Finalization_Exception_Data;
6286 Core_Loop : Node_Id;
6289 Loop_Id : Entity_Id;
6292 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6295 Final_Decls := New_List;
6298 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6301 Make_Indexed_Component (Loc,
6302 Prefix => Make_Identifier (Loc, Name_V),
6303 Expressions => New_References_To (Index_List, Loc));
6304 Set_Etype (Comp_Ref, Comp_Typ);
6307 -- [Deep_]Adjust (V (J1, ..., JN))
6309 if Prim = Adjust_Case then
6310 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6313 -- [Deep_]Finalize (V (J1, ..., JN))
6315 else pragma Assert (Prim = Finalize_Case);
6316 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6319 if Present (Call) then
6321 -- Generate the block which houses the adjust or finalize call:
6324 -- <adjust or finalize call>
6328 -- if not Raised then
6330 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6334 if Exceptions_OK then
6336 Make_Block_Statement (Loc,
6337 Handled_Statement_Sequence =>
6338 Make_Handled_Sequence_Of_Statements (Loc,
6339 Statements => New_List (Call),
6340 Exception_Handlers => New_List (
6341 Build_Exception_Handler (Final_Data))));
6346 -- Generate the dimension loops starting from the innermost one
6348 -- for Jnn in [reverse] V'Range (Dim) loop
6352 J := Last (Index_List);
6354 while Present (J) and then Dim > 0 loop
6360 Make_Loop_Statement (Loc,
6362 Make_Iteration_Scheme (Loc,
6363 Loop_Parameter_Specification =>
6364 Make_Loop_Parameter_Specification (Loc,
6365 Defining_Identifier => Loop_Id,
6366 Discrete_Subtype_Definition =>
6367 Make_Attribute_Reference (Loc,
6368 Prefix => Make_Identifier (Loc, Name_V),
6369 Attribute_Name => Name_Range,
6370 Expressions => New_List (
6371 Make_Integer_Literal (Loc, Dim))),
6374 Prim = Finalize_Case)),
6376 Statements => New_List (Core_Loop),
6377 End_Label => Empty);
6382 -- Generate the block which contains the core loop, declarations
6383 -- of the abort flag, the exception occurrence, the raised flag
6384 -- and the conditional raise:
6387 -- Abort : constant Boolean := Triggered_By_Abort;
6389 -- Abort : constant Boolean := False; -- no abort
6391 -- E : Exception_Occurrence;
6392 -- Raised : Boolean := False;
6397 -- if Raised and then not Abort then
6398 -- Raise_From_Controlled_Operation (E);
6402 Stmts := New_List (Core_Loop);
6404 if Exceptions_OK then
6405 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6409 Make_Block_Statement (Loc,
6410 Declarations => Final_Decls,
6411 Handled_Statement_Sequence =>
6412 Make_Handled_Sequence_Of_Statements (Loc,
6413 Statements => Stmts));
6415 -- Otherwise previous errors or a missing full view may prevent the
6416 -- proper freezing of the component type. If this is the case, there
6417 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6420 Block := Make_Null_Statement (Loc);
6423 return New_List (Block);
6424 end Build_Adjust_Or_Finalize_Statements;
6426 ---------------------------------
6427 -- Build_Initialize_Statements --
6428 ---------------------------------
6430 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
6431 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6432 Final_List : constant List_Id := New_List;
6433 Index_List : constant List_Id := New_List;
6434 Loc : constant Source_Ptr := Sloc (Typ);
6435 Num_Dims : constant Int := Number_Dimensions (Typ);
6437 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
6438 -- Generate the following assignment:
6439 -- Counter := V'Length (1) *
6441 -- V'Length (N) - Counter;
6443 -- Counter_Id denotes the entity of the counter.
6445 function Build_Finalization_Call return Node_Id;
6446 -- Generate a deep finalization call for an array element
6448 procedure Build_Indexes;
6449 -- Generate the initialization and finalization indexes used in the
6452 function Build_Initialization_Call return Node_Id;
6453 -- Generate a deep initialization call for an array element
6455 ----------------------
6456 -- Build_Assignment --
6457 ----------------------
6459 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
6464 -- Start from the first dimension and generate:
6469 Make_Attribute_Reference (Loc,
6470 Prefix => Make_Identifier (Loc, Name_V),
6471 Attribute_Name => Name_Length,
6472 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
6474 -- Process the rest of the dimensions, generate:
6475 -- Expr * V'Length (N)
6478 while Dim <= Num_Dims loop
6480 Make_Op_Multiply (Loc,
6483 Make_Attribute_Reference (Loc,
6484 Prefix => Make_Identifier (Loc, Name_V),
6485 Attribute_Name => Name_Length,
6486 Expressions => New_List (
6487 Make_Integer_Literal (Loc, Dim))));
6493 -- Counter := Expr - Counter;
6496 Make_Assignment_Statement (Loc,
6497 Name => New_Occurrence_Of (Counter_Id, Loc),
6499 Make_Op_Subtract (Loc,
6501 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
6502 end Build_Assignment;
6504 -----------------------------
6505 -- Build_Finalization_Call --
6506 -----------------------------
6508 function Build_Finalization_Call return Node_Id is
6509 Comp_Ref : constant Node_Id :=
6510 Make_Indexed_Component (Loc,
6511 Prefix => Make_Identifier (Loc, Name_V),
6512 Expressions => New_References_To (Final_List, Loc));
6515 Set_Etype (Comp_Ref, Comp_Typ);
6518 -- [Deep_]Finalize (V);
6520 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6521 end Build_Finalization_Call;
6527 procedure Build_Indexes is
6529 -- Generate the following identifiers:
6530 -- Jnn - for initialization
6531 -- Fnn - for finalization
6533 for Dim in 1 .. Num_Dims loop
6534 Append_To (Index_List,
6535 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6537 Append_To (Final_List,
6538 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
6542 -------------------------------
6543 -- Build_Initialization_Call --
6544 -------------------------------
6546 function Build_Initialization_Call return Node_Id is
6547 Comp_Ref : constant Node_Id :=
6548 Make_Indexed_Component (Loc,
6549 Prefix => Make_Identifier (Loc, Name_V),
6550 Expressions => New_References_To (Index_List, Loc));
6553 Set_Etype (Comp_Ref, Comp_Typ);
6556 -- [Deep_]Initialize (V (J1, ..., JN));
6558 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6559 end Build_Initialization_Call;
6563 Counter_Id : Entity_Id;
6567 Final_Block : Node_Id;
6568 Final_Data : Finalization_Exception_Data;
6569 Final_Decls : List_Id := No_List;
6570 Final_Loop : Node_Id;
6571 Init_Block : Node_Id;
6572 Init_Call : Node_Id;
6573 Init_Loop : Node_Id;
6578 -- Start of processing for Build_Initialize_Statements
6581 Counter_Id := Make_Temporary (Loc, 'C');
6582 Final_Decls := New_List;
6585 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6587 -- Generate the block which houses the finalization call, the index
6588 -- guard and the handler which triggers Program_Error later on.
6590 -- if Counter > 0 then
6591 -- Counter := Counter - 1;
6594 -- [Deep_]Finalize (V (F1, ..., FN));
6597 -- if not Raised then
6599 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6604 Fin_Stmt := Build_Finalization_Call;
6606 if Present (Fin_Stmt) then
6607 if Exceptions_OK then
6609 Make_Block_Statement (Loc,
6610 Handled_Statement_Sequence =>
6611 Make_Handled_Sequence_Of_Statements (Loc,
6612 Statements => New_List (Fin_Stmt),
6613 Exception_Handlers => New_List (
6614 Build_Exception_Handler (Final_Data))));
6617 -- This is the core of the loop, the dimension iterators are added
6618 -- one by one in reverse.
6621 Make_If_Statement (Loc,
6624 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6625 Right_Opnd => Make_Integer_Literal (Loc, 0)),
6627 Then_Statements => New_List (
6628 Make_Assignment_Statement (Loc,
6629 Name => New_Occurrence_Of (Counter_Id, Loc),
6631 Make_Op_Subtract (Loc,
6632 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6633 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
6635 Else_Statements => New_List (Fin_Stmt));
6637 -- Generate all finalization loops starting from the innermost
6640 -- for Fnn in reverse V'Range (Dim) loop
6644 F := Last (Final_List);
6646 while Present (F) and then Dim > 0 loop
6652 Make_Loop_Statement (Loc,
6654 Make_Iteration_Scheme (Loc,
6655 Loop_Parameter_Specification =>
6656 Make_Loop_Parameter_Specification (Loc,
6657 Defining_Identifier => Loop_Id,
6658 Discrete_Subtype_Definition =>
6659 Make_Attribute_Reference (Loc,
6660 Prefix => Make_Identifier (Loc, Name_V),
6661 Attribute_Name => Name_Range,
6662 Expressions => New_List (
6663 Make_Integer_Literal (Loc, Dim))),
6665 Reverse_Present => True)),
6667 Statements => New_List (Final_Loop),
6668 End_Label => Empty);
6673 -- Generate the block which contains the finalization loops, the
6674 -- declarations of the abort flag, the exception occurrence, the
6675 -- raised flag and the conditional raise.
6678 -- Abort : constant Boolean := Triggered_By_Abort;
6680 -- Abort : constant Boolean := False; -- no abort
6682 -- E : Exception_Occurrence;
6683 -- Raised : Boolean := False;
6689 -- V'Length (N) - Counter;
6693 -- if Raised and then not Abort then
6694 -- Raise_From_Controlled_Operation (E);
6700 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
6702 if Exceptions_OK then
6703 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6704 Append_To (Stmts, Make_Raise_Statement (Loc));
6708 Make_Block_Statement (Loc,
6709 Declarations => Final_Decls,
6710 Handled_Statement_Sequence =>
6711 Make_Handled_Sequence_Of_Statements (Loc,
6712 Statements => Stmts));
6714 -- Otherwise previous errors or a missing full view may prevent the
6715 -- proper freezing of the component type. If this is the case, there
6716 -- is no [Deep_]Finalize primitive to call.
6719 Final_Block := Make_Null_Statement (Loc);
6722 -- Generate the block which contains the initialization call and
6723 -- the partial finalization code.
6726 -- [Deep_]Initialize (V (J1, ..., JN));
6728 -- Counter := Counter + 1;
6732 -- <finalization code>
6735 Init_Call := Build_Initialization_Call;
6737 -- Only create finalization block if there is a nontrivial call
6738 -- to initialization or a Default_Initial_Condition check to be
6741 if (Present (Init_Call)
6742 and then Nkind (Init_Call) /= N_Null_Statement)
6745 and then not GNATprove_Mode
6746 and then Present (DIC_Procedure (Comp_Typ))
6747 and then not Has_Null_Body (DIC_Procedure (Comp_Typ)))
6750 Init_Stmts : constant List_Id := New_List;
6753 if Present (Init_Call) then
6754 Append_To (Init_Stmts, Init_Call);
6757 if Has_DIC (Comp_Typ)
6758 and then Present (DIC_Procedure (Comp_Typ))
6762 Build_DIC_Call (Loc,
6763 Make_Indexed_Component (Loc,
6764 Prefix => Make_Identifier (Loc, Name_V),
6765 Expressions => New_References_To (Index_List, Loc)),
6770 Make_Block_Statement (Loc,
6771 Handled_Statement_Sequence =>
6772 Make_Handled_Sequence_Of_Statements (Loc,
6773 Statements => Init_Stmts,
6774 Exception_Handlers => New_List (
6775 Make_Exception_Handler (Loc,
6776 Exception_Choices => New_List (
6777 Make_Others_Choice (Loc)),
6778 Statements => New_List (Final_Block)))));
6781 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
6782 Make_Assignment_Statement (Loc,
6783 Name => New_Occurrence_Of (Counter_Id, Loc),
6786 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6787 Right_Opnd => Make_Integer_Literal (Loc, 1))));
6789 -- Generate all initialization loops starting from the innermost
6792 -- for Jnn in V'Range (Dim) loop
6796 J := Last (Index_List);
6798 while Present (J) and then Dim > 0 loop
6804 Make_Loop_Statement (Loc,
6806 Make_Iteration_Scheme (Loc,
6807 Loop_Parameter_Specification =>
6808 Make_Loop_Parameter_Specification (Loc,
6809 Defining_Identifier => Loop_Id,
6810 Discrete_Subtype_Definition =>
6811 Make_Attribute_Reference (Loc,
6812 Prefix => Make_Identifier (Loc, Name_V),
6813 Attribute_Name => Name_Range,
6814 Expressions => New_List (
6815 Make_Integer_Literal (Loc, Dim))))),
6817 Statements => New_List (Init_Loop),
6818 End_Label => Empty);
6823 -- Generate the block which contains the counter variable and the
6824 -- initialization loops.
6827 -- Counter : Integer := 0;
6833 Make_Block_Statement (Loc,
6834 Declarations => New_List (
6835 Make_Object_Declaration (Loc,
6836 Defining_Identifier => Counter_Id,
6837 Object_Definition =>
6838 New_Occurrence_Of (Standard_Integer, Loc),
6839 Expression => Make_Integer_Literal (Loc, 0))),
6841 Handled_Statement_Sequence =>
6842 Make_Handled_Sequence_Of_Statements (Loc,
6843 Statements => New_List (Init_Loop)));
6845 if Debug_Generated_Code then
6846 Set_Debug_Info_Needed (Counter_Id);
6849 -- Otherwise previous errors or a missing full view may prevent the
6850 -- proper freezing of the component type. If this is the case, there
6851 -- is no [Deep_]Initialize primitive to call.
6854 Init_Block := Make_Null_Statement (Loc);
6857 return New_List (Init_Block);
6858 end Build_Initialize_Statements;
6860 -----------------------
6861 -- New_References_To --
6862 -----------------------
6864 function New_References_To
6866 Loc : Source_Ptr) return List_Id
6868 Refs : constant List_Id := New_List;
6873 while Present (Id) loop
6874 Append_To (Refs, New_Occurrence_Of (Id, Loc));
6879 end New_References_To;
6881 -- Start of processing for Make_Deep_Array_Body
6885 when Address_Case =>
6886 return Make_Finalize_Address_Stmts (Typ);
6891 return Build_Adjust_Or_Finalize_Statements (Typ);
6893 when Initialize_Case =>
6894 return Build_Initialize_Statements (Typ);
6896 end Make_Deep_Array_Body;
6898 --------------------
6899 -- Make_Deep_Proc --
6900 --------------------
6902 function Make_Deep_Proc
6903 (Prim : Final_Primitives;
6905 Stmts : List_Id) return Entity_Id
6907 Loc : constant Source_Ptr := Sloc (Typ);
6909 Proc_Id : Entity_Id;
6912 -- Create the object formal, generate:
6913 -- V : System.Address
6915 if Prim = Address_Case then
6916 Formals := New_List (
6917 Make_Parameter_Specification (Loc,
6918 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6920 New_Occurrence_Of (RTE (RE_Address), Loc)));
6927 Formals := New_List (
6928 Make_Parameter_Specification (Loc,
6929 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6931 Out_Present => True,
6932 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
6934 -- F : Boolean := True
6936 if Prim = Adjust_Case
6937 or else Prim = Finalize_Case
6940 Make_Parameter_Specification (Loc,
6941 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
6943 New_Occurrence_Of (Standard_Boolean, Loc),
6945 New_Occurrence_Of (Standard_True, Loc)));
6950 Make_Defining_Identifier (Loc,
6951 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
6954 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6957 -- exception -- Finalize and Adjust cases only
6958 -- raise Program_Error;
6959 -- end Deep_Initialize / Adjust / Finalize;
6963 -- procedure Finalize_Address (V : System.Address) is
6966 -- end Finalize_Address;
6969 Make_Subprogram_Body (Loc,
6971 Make_Procedure_Specification (Loc,
6972 Defining_Unit_Name => Proc_Id,
6973 Parameter_Specifications => Formals),
6975 Declarations => Empty_List,
6977 Handled_Statement_Sequence =>
6978 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
6980 -- If there are no calls to component initialization, indicate that
6981 -- the procedure is trivial, so prevent calls to it.
6983 if Is_Empty_List (Stmts)
6984 or else Nkind (First (Stmts)) = N_Null_Statement
6986 Set_Is_Trivial_Subprogram (Proc_Id);
6992 ---------------------------
6993 -- Make_Deep_Record_Body --
6994 ---------------------------
6996 function Make_Deep_Record_Body
6997 (Prim : Final_Primitives;
6999 Is_Local : Boolean := False) return List_Id
7001 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
7002 -- Build the statements necessary to adjust a record type. The type may
7003 -- have discriminants and contain variant parts. Generate:
7007 -- [Deep_]Adjust (V.Comp_1);
7009 -- when Id : others =>
7010 -- if not Raised then
7012 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7017 -- [Deep_]Adjust (V.Comp_N);
7019 -- when Id : others =>
7020 -- if not Raised then
7022 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7027 -- Deep_Adjust (V._parent, False); -- If applicable
7029 -- when Id : others =>
7030 -- if not Raised then
7032 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7038 -- Adjust (V); -- If applicable
7041 -- if not Raised then
7043 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7048 -- if Raised and then not Abort then
7049 -- Raise_From_Controlled_Operation (E);
7053 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
7054 -- Build the statements necessary to finalize a record type. The type
7055 -- may have discriminants and contain variant parts. Generate:
7058 -- Abort : constant Boolean := Triggered_By_Abort;
7060 -- Abort : constant Boolean := False; -- no abort
7061 -- E : Exception_Occurrence;
7062 -- Raised : Boolean := False;
7067 -- Finalize (V); -- If applicable
7070 -- if not Raised then
7072 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7077 -- case Variant_1 is
7079 -- case State_Counter_N => -- If Is_Local is enabled
7089 -- <<LN>> -- If Is_Local is enabled
7091 -- [Deep_]Finalize (V.Comp_N);
7094 -- if not Raised then
7096 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7102 -- [Deep_]Finalize (V.Comp_1);
7105 -- if not Raised then
7107 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7113 -- case State_Counter_1 => -- If Is_Local is enabled
7119 -- Deep_Finalize (V._parent, False); -- If applicable
7121 -- when Id : others =>
7122 -- if not Raised then
7124 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7128 -- if Raised and then not Abort then
7129 -- Raise_From_Controlled_Operation (E);
7133 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
7134 -- Given a derived tagged type Typ, traverse all components, find field
7135 -- _parent and return its type.
7137 procedure Preprocess_Components
7139 Num_Comps : out Nat;
7140 Has_POC : out Boolean);
7141 -- Examine all components in component list Comps, count all controlled
7142 -- components and determine whether at least one of them is per-object
7143 -- constrained. Component _parent is always skipped.
7145 -----------------------------
7146 -- Build_Adjust_Statements --
7147 -----------------------------
7149 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
7150 Loc : constant Source_Ptr := Sloc (Typ);
7151 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7153 Finalizer_Data : Finalization_Exception_Data;
7155 function Process_Component_List_For_Adjust
7156 (Comps : Node_Id) return List_Id;
7157 -- Build all necessary adjust statements for a single component list
7159 ---------------------------------------
7160 -- Process_Component_List_For_Adjust --
7161 ---------------------------------------
7163 function Process_Component_List_For_Adjust
7164 (Comps : Node_Id) return List_Id
7166 Stmts : constant List_Id := New_List;
7168 procedure Process_Component_For_Adjust (Decl : Node_Id);
7169 -- Process the declaration of a single controlled component
7171 ----------------------------------
7172 -- Process_Component_For_Adjust --
7173 ----------------------------------
7175 procedure Process_Component_For_Adjust (Decl : Node_Id) is
7176 Id : constant Entity_Id := Defining_Identifier (Decl);
7177 Typ : constant Entity_Id := Etype (Id);
7183 -- [Deep_]Adjust (V.Id);
7187 -- if not Raised then
7189 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7196 Make_Selected_Component (Loc,
7197 Prefix => Make_Identifier (Loc, Name_V),
7198 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7201 -- Guard against a missing [Deep_]Adjust when the component
7202 -- type was not properly frozen.
7204 if Present (Adj_Call) then
7205 if Exceptions_OK then
7207 Make_Block_Statement (Loc,
7208 Handled_Statement_Sequence =>
7209 Make_Handled_Sequence_Of_Statements (Loc,
7210 Statements => New_List (Adj_Call),
7211 Exception_Handlers => New_List (
7212 Build_Exception_Handler (Finalizer_Data))));
7215 Append_To (Stmts, Adj_Call);
7217 end Process_Component_For_Adjust;
7222 Decl_Id : Entity_Id;
7223 Decl_Typ : Entity_Id;
7228 -- Start of processing for Process_Component_List_For_Adjust
7231 -- Perform an initial check, determine the number of controlled
7232 -- components in the current list and whether at least one of them
7233 -- is per-object constrained.
7235 Preprocess_Components (Comps, Num_Comps, Has_POC);
7237 -- The processing in this routine is done in the following order:
7238 -- 1) Regular components
7239 -- 2) Per-object constrained components
7242 if Num_Comps > 0 then
7244 -- Process all regular components in order of declarations
7246 Decl := First_Non_Pragma (Component_Items (Comps));
7247 while Present (Decl) loop
7248 Decl_Id := Defining_Identifier (Decl);
7249 Decl_Typ := Etype (Decl_Id);
7251 -- Skip _parent as well as per-object constrained components
7253 if Chars (Decl_Id) /= Name_uParent
7254 and then Needs_Finalization (Decl_Typ)
7256 if Has_Access_Constraint (Decl_Id)
7257 and then No (Expression (Decl))
7261 Process_Component_For_Adjust (Decl);
7265 Next_Non_Pragma (Decl);
7268 -- Process all per-object constrained components in order of
7272 Decl := First_Non_Pragma (Component_Items (Comps));
7273 while Present (Decl) loop
7274 Decl_Id := Defining_Identifier (Decl);
7275 Decl_Typ := Etype (Decl_Id);
7279 if Chars (Decl_Id) /= Name_uParent
7280 and then Needs_Finalization (Decl_Typ)
7281 and then Has_Access_Constraint (Decl_Id)
7282 and then No (Expression (Decl))
7284 Process_Component_For_Adjust (Decl);
7287 Next_Non_Pragma (Decl);
7292 -- Process all variants, if any
7295 if Present (Variant_Part (Comps)) then
7297 Var_Alts : constant List_Id := New_List;
7301 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7302 while Present (Var) loop
7305 -- when <discrete choices> =>
7306 -- <adjust statements>
7308 Append_To (Var_Alts,
7309 Make_Case_Statement_Alternative (Loc,
7311 New_Copy_List (Discrete_Choices (Var)),
7313 Process_Component_List_For_Adjust (
7314 Component_List (Var))));
7316 Next_Non_Pragma (Var);
7320 -- case V.<discriminant> is
7321 -- when <discrete choices 1> =>
7322 -- <adjust statements 1>
7324 -- when <discrete choices N> =>
7325 -- <adjust statements N>
7329 Make_Case_Statement (Loc,
7331 Make_Selected_Component (Loc,
7332 Prefix => Make_Identifier (Loc, Name_V),
7334 Make_Identifier (Loc,
7335 Chars => Chars (Name (Variant_Part (Comps))))),
7336 Alternatives => Var_Alts);
7340 -- Add the variant case statement to the list of statements
7342 if Present (Var_Case) then
7343 Append_To (Stmts, Var_Case);
7346 -- If the component list did not have any controlled components
7347 -- nor variants, return null.
7349 if Is_Empty_List (Stmts) then
7350 Append_To (Stmts, Make_Null_Statement (Loc));
7354 end Process_Component_List_For_Adjust;
7358 Bod_Stmts : List_Id := No_List;
7359 Finalizer_Decls : List_Id := No_List;
7362 -- Start of processing for Build_Adjust_Statements
7365 Finalizer_Decls := New_List;
7366 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7368 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7369 Rec_Def := Record_Extension_Part (Typ_Def);
7374 -- Create an adjust sequence for all record components
7376 if Present (Component_List (Rec_Def)) then
7378 Process_Component_List_For_Adjust (Component_List (Rec_Def));
7381 -- A derived record type must adjust all inherited components. This
7382 -- action poses the following problem:
7384 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7389 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7391 -- Deep_Adjust (Obj._parent);
7396 -- Adjusting the derived type will invoke Adjust of the parent and
7397 -- then that of the derived type. This is undesirable because both
7398 -- routines may modify shared components. Only the Adjust of the
7399 -- derived type should be invoked.
7401 -- To prevent this double adjustment of shared components,
7402 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7404 -- procedure Deep_Adjust
7405 -- (Obj : in out Some_Type;
7406 -- Flag : Boolean := True)
7414 -- When Deep_Adjust is invoked for field _parent, a value of False is
7415 -- provided for the flag:
7417 -- Deep_Adjust (Obj._parent, False);
7419 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7421 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7426 if Needs_Finalization (Par_Typ) then
7430 Make_Selected_Component (Loc,
7431 Prefix => Make_Identifier (Loc, Name_V),
7433 Make_Identifier (Loc, Name_uParent)),
7439 -- Deep_Adjust (V._parent, False);
7442 -- when Id : others =>
7443 -- if not Raised then
7445 -- Save_Occurrence (E,
7446 -- Get_Current_Excep.all.all);
7450 if Present (Call) then
7453 if Exceptions_OK then
7455 Make_Block_Statement (Loc,
7456 Handled_Statement_Sequence =>
7457 Make_Handled_Sequence_Of_Statements (Loc,
7458 Statements => New_List (Adj_Stmt),
7459 Exception_Handlers => New_List (
7460 Build_Exception_Handler (Finalizer_Data))));
7463 Prepend_To (Bod_Stmts, Adj_Stmt);
7469 -- Adjust the object. This action must be performed last after all
7470 -- components have been adjusted.
7472 if Is_Controlled (Typ) then
7478 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
7487 -- if not Raised then
7489 -- Save_Occurrence (E,
7490 -- Get_Current_Excep.all.all);
7495 if Present (Proc) then
7497 Make_Procedure_Call_Statement (Loc,
7498 Name => New_Occurrence_Of (Proc, Loc),
7499 Parameter_Associations => New_List (
7500 Make_Identifier (Loc, Name_V)));
7502 if Exceptions_OK then
7504 Make_Block_Statement (Loc,
7505 Handled_Statement_Sequence =>
7506 Make_Handled_Sequence_Of_Statements (Loc,
7507 Statements => New_List (Adj_Stmt),
7508 Exception_Handlers => New_List (
7509 Build_Exception_Handler
7510 (Finalizer_Data))));
7513 Append_To (Bod_Stmts,
7514 Make_If_Statement (Loc,
7515 Condition => Make_Identifier (Loc, Name_F),
7516 Then_Statements => New_List (Adj_Stmt)));
7521 -- At this point either all adjustment statements have been generated
7522 -- or the type is not controlled.
7524 if Is_Empty_List (Bod_Stmts) then
7525 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
7531 -- Abort : constant Boolean := Triggered_By_Abort;
7533 -- Abort : constant Boolean := False; -- no abort
7535 -- E : Exception_Occurrence;
7536 -- Raised : Boolean := False;
7539 -- <adjust statements>
7541 -- if Raised and then not Abort then
7542 -- Raise_From_Controlled_Operation (E);
7547 if Exceptions_OK then
7548 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7553 Make_Block_Statement (Loc,
7556 Handled_Statement_Sequence =>
7557 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7559 end Build_Adjust_Statements;
7561 -------------------------------
7562 -- Build_Finalize_Statements --
7563 -------------------------------
7565 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
7566 Loc : constant Source_Ptr := Sloc (Typ);
7567 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7570 Finalizer_Data : Finalization_Exception_Data;
7571 Last_POC_Call : Node_Id := Empty;
7573 function Process_Component_List_For_Finalize
7575 In_Variant_Part : Boolean := False) return List_Id;
7576 -- Build all necessary finalization statements for a single component
7577 -- list. The statements may include a jump circuitry if flag Is_Local
7578 -- is enabled. In_Variant_Part indicates whether this is a recursive
7581 -----------------------------------------
7582 -- Process_Component_List_For_Finalize --
7583 -----------------------------------------
7585 function Process_Component_List_For_Finalize
7587 In_Variant_Part : Boolean := False) return List_Id
7589 procedure Process_Component_For_Finalize
7594 Num_Comps : in out Nat);
7595 -- Process the declaration of a single controlled component. If
7596 -- flag Is_Local is enabled, create the corresponding label and
7597 -- jump circuitry. Alts is the list of case alternatives, Decls
7598 -- is the top level declaration list where labels are declared
7599 -- and Stmts is the list of finalization actions. Num_Comps
7600 -- denotes the current number of components needing finalization.
7602 ------------------------------------
7603 -- Process_Component_For_Finalize --
7604 ------------------------------------
7606 procedure Process_Component_For_Finalize
7611 Num_Comps : in out Nat)
7613 Id : constant Entity_Id := Defining_Identifier (Decl);
7614 Typ : constant Entity_Id := Etype (Id);
7621 Label_Id : Entity_Id;
7628 Make_Identifier (Loc,
7629 Chars => New_External_Name ('L', Num_Comps));
7630 Set_Entity (Label_Id,
7631 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7632 Label := Make_Label (Loc, Label_Id);
7635 Make_Implicit_Label_Declaration (Loc,
7636 Defining_Identifier => Entity (Label_Id),
7637 Label_Construct => Label));
7644 Make_Case_Statement_Alternative (Loc,
7645 Discrete_Choices => New_List (
7646 Make_Integer_Literal (Loc, Num_Comps)),
7648 Statements => New_List (
7649 Make_Goto_Statement (Loc,
7651 New_Occurrence_Of (Entity (Label_Id), Loc)))));
7656 Append_To (Stmts, Label);
7658 -- Decrease the number of components to be processed.
7659 -- This action yields a new Label_Id in future calls.
7661 Num_Comps := Num_Comps - 1;
7666 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7668 -- begin -- Exception handlers allowed
7669 -- [Deep_]Finalize (V.Id);
7672 -- if not Raised then
7674 -- Save_Occurrence (E,
7675 -- Get_Current_Excep.all.all);
7682 Make_Selected_Component (Loc,
7683 Prefix => Make_Identifier (Loc, Name_V),
7684 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7687 -- Guard against a missing [Deep_]Finalize when the component
7688 -- type was not properly frozen.
7690 if Present (Fin_Call) then
7691 if Exceptions_OK then
7693 Make_Block_Statement (Loc,
7694 Handled_Statement_Sequence =>
7695 Make_Handled_Sequence_Of_Statements (Loc,
7696 Statements => New_List (Fin_Call),
7697 Exception_Handlers => New_List (
7698 Build_Exception_Handler (Finalizer_Data))));
7701 Append_To (Stmts, Fin_Call);
7703 end Process_Component_For_Finalize;
7708 Counter_Id : Entity_Id := Empty;
7710 Decl_Id : Entity_Id;
7711 Decl_Typ : Entity_Id;
7714 Jump_Block : Node_Id;
7716 Label_Id : Entity_Id;
7721 -- Start of processing for Process_Component_List_For_Finalize
7724 -- Perform an initial check, look for controlled and per-object
7725 -- constrained components.
7727 Preprocess_Components (Comps, Num_Comps, Has_POC);
7729 -- Create a state counter to service the current component list.
7730 -- This step is performed before the variants are inspected in
7731 -- order to generate the same state counter names as those from
7732 -- Build_Initialize_Statements.
7734 if Num_Comps > 0 and then Is_Local then
7735 Counter := Counter + 1;
7738 Make_Defining_Identifier (Loc,
7739 Chars => New_External_Name ('C', Counter));
7742 -- Process the component in the following order:
7744 -- 2) Per-object constrained components
7745 -- 3) Regular components
7747 -- Start with the variant parts
7750 if Present (Variant_Part (Comps)) then
7752 Var_Alts : constant List_Id := New_List;
7756 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7757 while Present (Var) loop
7760 -- when <discrete choices> =>
7761 -- <finalize statements>
7763 Append_To (Var_Alts,
7764 Make_Case_Statement_Alternative (Loc,
7766 New_Copy_List (Discrete_Choices (Var)),
7768 Process_Component_List_For_Finalize (
7769 Component_List (Var),
7770 In_Variant_Part => True)));
7772 Next_Non_Pragma (Var);
7776 -- case V.<discriminant> is
7777 -- when <discrete choices 1> =>
7778 -- <finalize statements 1>
7780 -- when <discrete choices N> =>
7781 -- <finalize statements N>
7785 Make_Case_Statement (Loc,
7787 Make_Selected_Component (Loc,
7788 Prefix => Make_Identifier (Loc, Name_V),
7790 Make_Identifier (Loc,
7791 Chars => Chars (Name (Variant_Part (Comps))))),
7792 Alternatives => Var_Alts);
7796 -- The current component list does not have a single controlled
7797 -- component, however it may contain variants. Return the case
7798 -- statement for the variants or nothing.
7800 if Num_Comps = 0 then
7801 if Present (Var_Case) then
7802 return New_List (Var_Case);
7804 return New_List (Make_Null_Statement (Loc));
7808 -- Prepare all lists
7814 -- Process all per-object constrained components in reverse order
7817 Decl := Last_Non_Pragma (Component_Items (Comps));
7818 while Present (Decl) loop
7819 Decl_Id := Defining_Identifier (Decl);
7820 Decl_Typ := Etype (Decl_Id);
7824 if Chars (Decl_Id) /= Name_uParent
7825 and then Needs_Finalization (Decl_Typ)
7826 and then Has_Access_Constraint (Decl_Id)
7827 and then No (Expression (Decl))
7829 Process_Component_For_Finalize
7830 (Decl, Alts, Decls, Stmts, Num_Comps);
7833 Prev_Non_Pragma (Decl);
7837 if not In_Variant_Part then
7838 Last_POC_Call := Last (Stmts);
7839 -- In the case of a type extension, the deep-finalize call
7840 -- for the _Parent component will be inserted here.
7843 -- Process the rest of the components in reverse order
7845 Decl := Last_Non_Pragma (Component_Items (Comps));
7846 while Present (Decl) loop
7847 Decl_Id := Defining_Identifier (Decl);
7848 Decl_Typ := Etype (Decl_Id);
7852 if Chars (Decl_Id) /= Name_uParent
7853 and then Needs_Finalization (Decl_Typ)
7855 -- Skip per-object constrained components since they were
7856 -- handled in the above step.
7858 if Has_Access_Constraint (Decl_Id)
7859 and then No (Expression (Decl))
7863 Process_Component_For_Finalize
7864 (Decl, Alts, Decls, Stmts, Num_Comps);
7868 Prev_Non_Pragma (Decl);
7873 -- LN : label; -- If Is_Local is enabled
7878 -- case CounterX is .
7888 -- <<LN>> -- If Is_Local is enabled
7890 -- [Deep_]Finalize (V.CompY);
7892 -- when Id : others =>
7893 -- if not Raised then
7895 -- Save_Occurrence (E,
7896 -- Get_Current_Excep.all.all);
7900 -- <<L0>> -- If Is_Local is enabled
7905 -- Add the declaration of default jump location L0, its
7906 -- corresponding alternative and its place in the statements.
7908 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
7909 Set_Entity (Label_Id,
7910 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7911 Label := Make_Label (Loc, Label_Id);
7913 Append_To (Decls, -- declaration
7914 Make_Implicit_Label_Declaration (Loc,
7915 Defining_Identifier => Entity (Label_Id),
7916 Label_Construct => Label));
7918 Append_To (Alts, -- alternative
7919 Make_Case_Statement_Alternative (Loc,
7920 Discrete_Choices => New_List (
7921 Make_Others_Choice (Loc)),
7923 Statements => New_List (
7924 Make_Goto_Statement (Loc,
7925 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
7927 Append_To (Stmts, Label); -- statement
7929 -- Create the jump block
7932 Make_Case_Statement (Loc,
7933 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
7934 Alternatives => Alts));
7938 Make_Block_Statement (Loc,
7939 Declarations => Decls,
7940 Handled_Statement_Sequence =>
7941 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7943 if Present (Var_Case) then
7944 return New_List (Var_Case, Jump_Block);
7946 return New_List (Jump_Block);
7948 end Process_Component_List_For_Finalize;
7952 Bod_Stmts : List_Id := No_List;
7953 Finalizer_Decls : List_Id := No_List;
7956 -- Start of processing for Build_Finalize_Statements
7959 Finalizer_Decls := New_List;
7960 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7962 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7963 Rec_Def := Record_Extension_Part (Typ_Def);
7968 -- Create a finalization sequence for all record components
7970 if Present (Component_List (Rec_Def)) then
7972 Process_Component_List_For_Finalize (Component_List (Rec_Def));
7975 -- A derived record type must finalize all inherited components. This
7976 -- action poses the following problem:
7978 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7983 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7985 -- Deep_Finalize (Obj._parent);
7990 -- Finalizing the derived type will invoke Finalize of the parent and
7991 -- then that of the derived type. This is undesirable because both
7992 -- routines may modify shared components. Only the Finalize of the
7993 -- derived type should be invoked.
7995 -- To prevent this double adjustment of shared components,
7996 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7998 -- procedure Deep_Finalize
7999 -- (Obj : in out Some_Type;
8000 -- Flag : Boolean := True)
8008 -- When Deep_Finalize is invoked for field _parent, a value of False
8009 -- is provided for the flag:
8011 -- Deep_Finalize (Obj._parent, False);
8013 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8015 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8020 if Needs_Finalization (Par_Typ) then
8024 Make_Selected_Component (Loc,
8025 Prefix => Make_Identifier (Loc, Name_V),
8027 Make_Identifier (Loc, Name_uParent)),
8033 -- Deep_Finalize (V._parent, False);
8036 -- when Id : others =>
8037 -- if not Raised then
8039 -- Save_Occurrence (E,
8040 -- Get_Current_Excep.all.all);
8044 if Present (Call) then
8047 if Exceptions_OK then
8049 Make_Block_Statement (Loc,
8050 Handled_Statement_Sequence =>
8051 Make_Handled_Sequence_Of_Statements (Loc,
8052 Statements => New_List (Fin_Stmt),
8053 Exception_Handlers => New_List (
8054 Build_Exception_Handler
8055 (Finalizer_Data))));
8058 -- The intended component finalization order is
8059 -- 1) POC components of extension
8060 -- 2) _Parent component
8061 -- 3) non-POC components of extension.
8063 -- With this "finalize the parent part in the middle"
8064 -- ordering, we can avoid the need for making two
8065 -- calls to the parent's subprogram in the way that
8066 -- is necessary for Init_Procs. This does have the
8067 -- peculiar (but legal) consequence that the parent's
8068 -- non-POC components are finalized before the
8069 -- non-POC extension components. This violates the
8070 -- usual "finalize in reverse declaration order"
8071 -- principle, but that's ok (see Ada RM 7.6.1(9)).
8073 -- Last_POC_Call should be non-empty if the extension
8074 -- has at least one POC. Interactions with variant
8075 -- parts are incorrectly ignored.
8077 if Present (Last_POC_Call) then
8078 Insert_After (Last_POC_Call, Fin_Stmt);
8080 -- At this point, we could look for the common case
8081 -- where there are no POC components anywhere in
8082 -- sight (inherited or not) and, in that common case,
8083 -- call Append_To instead of Prepend_To. That would
8084 -- result in finalizing the parent part after, rather
8085 -- than before, the extension components. That might
8086 -- be more intuitive (as discussed in preceding
8087 -- comment), but it is not required.
8088 Prepend_To (Bod_Stmts, Fin_Stmt);
8095 -- Finalize the object. This action must be performed first before
8096 -- all components have been finalized.
8098 if Is_Controlled (Typ) and then not Is_Local then
8104 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
8113 -- if not Raised then
8115 -- Save_Occurrence (E,
8116 -- Get_Current_Excep.all.all);
8121 if Present (Proc) then
8123 Make_Procedure_Call_Statement (Loc,
8124 Name => New_Occurrence_Of (Proc, Loc),
8125 Parameter_Associations => New_List (
8126 Make_Identifier (Loc, Name_V)));
8128 if Exceptions_OK then
8130 Make_Block_Statement (Loc,
8131 Handled_Statement_Sequence =>
8132 Make_Handled_Sequence_Of_Statements (Loc,
8133 Statements => New_List (Fin_Stmt),
8134 Exception_Handlers => New_List (
8135 Build_Exception_Handler
8136 (Finalizer_Data))));
8139 Prepend_To (Bod_Stmts,
8140 Make_If_Statement (Loc,
8141 Condition => Make_Identifier (Loc, Name_F),
8142 Then_Statements => New_List (Fin_Stmt)));
8147 -- At this point either all finalization statements have been
8148 -- generated or the type is not controlled.
8150 if No (Bod_Stmts) then
8151 return New_List (Make_Null_Statement (Loc));
8155 -- Abort : constant Boolean := Triggered_By_Abort;
8157 -- Abort : constant Boolean := False; -- no abort
8159 -- E : Exception_Occurrence;
8160 -- Raised : Boolean := False;
8163 -- <finalize statements>
8165 -- if Raised and then not Abort then
8166 -- Raise_From_Controlled_Operation (E);
8171 if Exceptions_OK then
8172 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8177 Make_Block_Statement (Loc,
8180 Handled_Statement_Sequence =>
8181 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8183 end Build_Finalize_Statements;
8185 -----------------------
8186 -- Parent_Field_Type --
8187 -----------------------
8189 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
8193 Field := First_Entity (Typ);
8194 while Present (Field) loop
8195 if Chars (Field) = Name_uParent then
8196 return Etype (Field);
8199 Next_Entity (Field);
8202 -- A derived tagged type should always have a parent field
8204 raise Program_Error;
8205 end Parent_Field_Type;
8207 ---------------------------
8208 -- Preprocess_Components --
8209 ---------------------------
8211 procedure Preprocess_Components
8213 Num_Comps : out Nat;
8214 Has_POC : out Boolean)
8224 Decl := First_Non_Pragma (Component_Items (Comps));
8225 while Present (Decl) loop
8226 Id := Defining_Identifier (Decl);
8229 -- Skip field _parent
8231 if Chars (Id) /= Name_uParent
8232 and then Needs_Finalization (Typ)
8234 Num_Comps := Num_Comps + 1;
8236 if Has_Access_Constraint (Id)
8237 and then No (Expression (Decl))
8243 Next_Non_Pragma (Decl);
8245 end Preprocess_Components;
8247 -- Start of processing for Make_Deep_Record_Body
8251 when Address_Case =>
8252 return Make_Finalize_Address_Stmts (Typ);
8255 return Build_Adjust_Statements (Typ);
8257 when Finalize_Case =>
8258 return Build_Finalize_Statements (Typ);
8260 when Initialize_Case =>
8262 Loc : constant Source_Ptr := Sloc (Typ);
8265 if Is_Controlled (Typ) then
8267 Make_Procedure_Call_Statement (Loc,
8270 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
8271 Parameter_Associations => New_List (
8272 Make_Identifier (Loc, Name_V))));
8278 end Make_Deep_Record_Body;
8280 ----------------------
8281 -- Make_Final_Call --
8282 ----------------------
8284 function Make_Final_Call
8287 Skip_Self : Boolean := False) return Node_Id
8289 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8291 Prot_Typ : Entity_Id := Empty;
8292 Fin_Id : Entity_Id := Empty;
8299 -- Recover the proper type which contains [Deep_]Finalize
8301 if Is_Class_Wide_Type (Typ) then
8302 Utyp := Root_Type (Typ);
8305 elsif Is_Concurrent_Type (Typ) then
8306 Utyp := Corresponding_Record_Type (Typ);
8308 Ref := Convert_Concurrent (Ref, Typ);
8310 elsif Is_Private_Type (Typ)
8311 and then Present (Underlying_Type (Typ))
8312 and then Is_Concurrent_Type (Underlying_Type (Typ))
8314 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8316 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8323 Utyp := Underlying_Type (Base_Type (Utyp));
8324 Set_Assignment_OK (Ref);
8326 -- Deal with untagged derivation of private views. If the parent type
8327 -- is a protected type, Deep_Finalize is found on the corresponding
8328 -- record of the ancestor.
8330 if Is_Untagged_Derivation (Typ) then
8331 if Is_Protected_Type (Typ) then
8332 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
8334 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8336 if Is_Protected_Type (Utyp) then
8337 Utyp := Corresponding_Record_Type (Utyp);
8341 Ref := Unchecked_Convert_To (Utyp, Ref);
8342 Set_Assignment_OK (Ref);
8345 -- Deal with derived private types which do not inherit primitives from
8346 -- their parents. In this case, [Deep_]Finalize can be found in the full
8347 -- view of the parent type.
8350 and then Is_Tagged_Type (Utyp)
8351 and then Is_Derived_Type (Utyp)
8352 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
8353 and then Is_Private_Type (Etype (Utyp))
8354 and then Present (Full_View (Etype (Utyp)))
8356 Utyp := Full_View (Etype (Utyp));
8357 Ref := Unchecked_Convert_To (Utyp, Ref);
8358 Set_Assignment_OK (Ref);
8361 -- When dealing with the completion of a private type, use the base type
8364 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8365 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
8367 Utyp := Base_Type (Utyp);
8368 Ref := Unchecked_Convert_To (Utyp, Ref);
8369 Set_Assignment_OK (Ref);
8372 -- Detect if Typ is a protected type or an expanded protected type and
8373 -- store the relevant type within Prot_Typ for later processing.
8375 if Is_Protected_Type (Typ) then
8378 elsif Ekind (Typ) = E_Record_Type
8379 and then Present (Corresponding_Concurrent_Type (Typ))
8380 and then Is_Protected_Type (Corresponding_Concurrent_Type (Typ))
8382 Prot_Typ := Corresponding_Concurrent_Type (Typ);
8385 -- The underlying type may not be present due to a missing full view. In
8386 -- this case freezing did not take place and there is no [Deep_]Finalize
8387 -- primitive to call.
8392 elsif Skip_Self then
8393 if Has_Controlled_Component (Utyp) then
8394 if Is_Tagged_Type (Utyp) then
8395 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8397 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8401 -- Class-wide types, interfaces and types with controlled components
8403 elsif Is_Class_Wide_Type (Typ)
8404 or else Is_Interface (Typ)
8405 or else Has_Controlled_Component (Utyp)
8407 if Is_Tagged_Type (Utyp) then
8408 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8410 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8413 -- Derivations from [Limited_]Controlled
8415 elsif Is_Controlled (Utyp) then
8416 if Has_Controlled_Component (Utyp) then
8417 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8419 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
8424 elsif Is_Tagged_Type (Utyp) then
8425 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8427 -- Protected types: these also require finalization even though they
8428 -- are not marked controlled explicitly.
8430 elsif Present (Prot_Typ) then
8431 -- Protected objects do not need to be finalized on restricted
8434 if Restricted_Profile then
8437 -- ??? Only handle the simple case for now. Will not support a record
8438 -- or array containing protected objects.
8440 elsif Is_Simple_Protected_Type (Prot_Typ) then
8441 Fin_Id := RTE (RE_Finalize_Protection);
8443 raise Program_Error;
8446 raise Program_Error;
8449 if Present (Fin_Id) then
8451 -- When finalizing a class-wide object, do not convert to the root
8452 -- type in order to produce a dispatching call.
8454 if Is_Class_Wide_Type (Typ) then
8457 -- Ensure that a finalization routine is at least decorated in order
8458 -- to inspect the object parameter.
8460 elsif Analyzed (Fin_Id)
8461 or else Ekind (Fin_Id) = E_Procedure
8463 -- In certain cases, such as the creation of Stream_Read, the
8464 -- visible entity of the type is its full view. Since Stream_Read
8465 -- will have to create an object of type Typ, the local object
8466 -- will be finalzed by the scope finalizer generated later on. The
8467 -- object parameter of Deep_Finalize will always use the private
8468 -- view of the type. To avoid such a clash between a private and a
8469 -- full view, perform an unchecked conversion of the object
8470 -- reference to the private view.
8473 Formal_Typ : constant Entity_Id :=
8474 Etype (First_Formal (Fin_Id));
8476 if Is_Private_Type (Formal_Typ)
8477 and then Present (Full_View (Formal_Typ))
8478 and then Full_View (Formal_Typ) = Utyp
8480 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
8484 -- If the object is unanalyzed, set its expected type for use in
8485 -- Convert_View in case an additional conversion is needed.
8488 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
8490 Set_Etype (Ref, Typ);
8493 Ref := Convert_View (Fin_Id, Ref);
8500 Skip_Self => Skip_Self);
8504 end Make_Final_Call;
8506 --------------------------------
8507 -- Make_Finalize_Address_Body --
8508 --------------------------------
8510 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
8511 Is_Task : constant Boolean :=
8512 Ekind (Typ) = E_Record_Type
8513 and then Is_Concurrent_Record_Type (Typ)
8514 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
8516 Loc : constant Source_Ptr := Sloc (Typ);
8517 Proc_Id : Entity_Id;
8521 -- The corresponding records of task types are not controlled by design.
8522 -- For the sake of completeness, create an empty Finalize_Address to be
8523 -- used in task class-wide allocations.
8528 -- Nothing to do if the type is not controlled or it already has a
8529 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8530 -- come from source. These are usually generated for completeness and
8531 -- do not need the Finalize_Address primitive.
8533 elsif not Needs_Finalization (Typ)
8534 or else Present (TSS (Typ, TSS_Finalize_Address))
8536 (Is_Class_Wide_Type (Typ)
8537 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
8538 and then not Comes_From_Source (Root_Type (Typ)))
8543 -- Do not generate Finalize_Address routine for CodePeer
8545 if CodePeer_Mode then
8550 Make_Defining_Identifier (Loc,
8551 Make_TSS_Name (Typ, TSS_Finalize_Address));
8555 -- procedure <Typ>FD (V : System.Address) is
8557 -- null; -- for tasks
8559 -- declare -- for all other types
8560 -- type Pnn is access all Typ;
8561 -- for Pnn'Storage_Size use 0;
8563 -- [Deep_]Finalize (Pnn (V).all);
8568 Stmts := New_List (Make_Null_Statement (Loc));
8570 Stmts := Make_Finalize_Address_Stmts (Typ);
8574 Make_Subprogram_Body (Loc,
8576 Make_Procedure_Specification (Loc,
8577 Defining_Unit_Name => Proc_Id,
8579 Parameter_Specifications => New_List (
8580 Make_Parameter_Specification (Loc,
8581 Defining_Identifier =>
8582 Make_Defining_Identifier (Loc, Name_V),
8584 New_Occurrence_Of (RTE (RE_Address), Loc)))),
8586 Declarations => No_List,
8588 Handled_Statement_Sequence =>
8589 Make_Handled_Sequence_Of_Statements (Loc,
8590 Statements => Stmts)));
8592 Set_TSS (Typ, Proc_Id);
8593 end Make_Finalize_Address_Body;
8595 ---------------------------------
8596 -- Make_Finalize_Address_Stmts --
8597 ---------------------------------
8599 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
8600 Loc : constant Source_Ptr := Sloc (Typ);
8603 Desig_Typ : Entity_Id;
8604 Fin_Block : Node_Id;
8607 Ptr_Typ : Entity_Id;
8610 if Is_Array_Type (Typ) then
8611 if Is_Constrained (First_Subtype (Typ)) then
8612 Desig_Typ := First_Subtype (Typ);
8614 Desig_Typ := Base_Type (Typ);
8617 -- Class-wide types of constrained root types
8619 elsif Is_Class_Wide_Type (Typ)
8620 and then Has_Discriminants (Root_Type (Typ))
8622 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
8625 Parent_Typ : Entity_Id;
8628 -- Climb the parent type chain looking for a non-constrained type
8630 Parent_Typ := Root_Type (Typ);
8631 while Parent_Typ /= Etype (Parent_Typ)
8632 and then Has_Discriminants (Parent_Typ)
8634 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
8636 Parent_Typ := Etype (Parent_Typ);
8639 -- Handle views created for tagged types with unknown
8642 if Is_Underlying_Record_View (Parent_Typ) then
8643 Parent_Typ := Underlying_Record_View (Parent_Typ);
8646 Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
8656 -- type Ptr_Typ is access all Typ;
8657 -- for Ptr_Typ'Storage_Size use 0;
8659 Ptr_Typ := Make_Temporary (Loc, 'P');
8662 Make_Full_Type_Declaration (Loc,
8663 Defining_Identifier => Ptr_Typ,
8665 Make_Access_To_Object_Definition (Loc,
8666 All_Present => True,
8667 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
8669 Make_Attribute_Definition_Clause (Loc,
8670 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8671 Chars => Name_Storage_Size,
8672 Expression => Make_Integer_Literal (Loc, 0)));
8674 Obj_Expr := Make_Identifier (Loc, Name_V);
8676 -- Unconstrained arrays require special processing in order to retrieve
8677 -- the elements. To achieve this, we have to skip the dope vector which
8678 -- lays in front of the elements and then use a thin pointer to perform
8679 -- the address-to-access conversion.
8681 if Is_Array_Type (Typ)
8682 and then not Is_Constrained (First_Subtype (Typ))
8685 Dope_Id : Entity_Id;
8688 -- Ensure that Ptr_Typ is a thin pointer; generate:
8689 -- for Ptr_Typ'Size use System.Address'Size;
8692 Make_Attribute_Definition_Clause (Loc,
8693 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8696 Make_Integer_Literal (Loc, System_Address_Size)));
8699 -- Dnn : constant Storage_Offset :=
8700 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8702 Dope_Id := Make_Temporary (Loc, 'D');
8705 Make_Object_Declaration (Loc,
8706 Defining_Identifier => Dope_Id,
8707 Constant_Present => True,
8708 Object_Definition =>
8709 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
8711 Make_Op_Divide (Loc,
8713 Make_Attribute_Reference (Loc,
8714 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
8715 Attribute_Name => Name_Descriptor_Size),
8717 Make_Integer_Literal (Loc, System_Storage_Unit))));
8719 -- Shift the address from the start of the dope vector to the
8720 -- start of the elements:
8724 -- Note that this is done through a wrapper routine since RTSfind
8725 -- cannot retrieve operations with string names of the form "+".
8728 Make_Function_Call (Loc,
8730 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
8731 Parameter_Associations => New_List (
8733 New_Occurrence_Of (Dope_Id, Loc)));
8740 Make_Explicit_Dereference (Loc,
8741 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
8744 if Present (Fin_Call) then
8746 Make_Block_Statement (Loc,
8747 Declarations => Decls,
8748 Handled_Statement_Sequence =>
8749 Make_Handled_Sequence_Of_Statements (Loc,
8750 Statements => New_List (Fin_Call)));
8752 -- Otherwise previous errors or a missing full view may prevent the
8753 -- proper freezing of the designated type. If this is the case, there
8754 -- is no [Deep_]Finalize primitive to call.
8757 Fin_Block := Make_Null_Statement (Loc);
8760 return New_List (Fin_Block);
8761 end Make_Finalize_Address_Stmts;
8763 -------------------------------------
8764 -- Make_Handler_For_Ctrl_Operation --
8765 -------------------------------------
8769 -- when E : others =>
8770 -- Raise_From_Controlled_Operation (E);
8775 -- raise Program_Error [finalize raised exception];
8777 -- depending on whether Raise_From_Controlled_Operation is available
8779 function Make_Handler_For_Ctrl_Operation
8780 (Loc : Source_Ptr) return Node_Id
8783 -- Choice parameter (for the first case above)
8785 Raise_Node : Node_Id;
8786 -- Procedure call or raise statement
8789 -- Standard run-time: add choice parameter E and pass it to
8790 -- Raise_From_Controlled_Operation so that the original exception
8791 -- name and message can be recorded in the exception message for
8794 if RTE_Available (RE_Raise_From_Controlled_Operation) then
8795 E_Occ := Make_Defining_Identifier (Loc, Name_E);
8797 Make_Procedure_Call_Statement (Loc,
8800 (RTE (RE_Raise_From_Controlled_Operation), Loc),
8801 Parameter_Associations => New_List (
8802 New_Occurrence_Of (E_Occ, Loc)));
8804 -- Restricted run-time: exception messages are not supported
8809 Make_Raise_Program_Error (Loc,
8810 Reason => PE_Finalize_Raised_Exception);
8814 Make_Implicit_Exception_Handler (Loc,
8815 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8816 Choice_Parameter => E_Occ,
8817 Statements => New_List (Raise_Node));
8818 end Make_Handler_For_Ctrl_Operation;
8820 --------------------
8821 -- Make_Init_Call --
8822 --------------------
8824 function Make_Init_Call
8826 Typ : Entity_Id) return Node_Id
8828 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8837 -- Deal with the type and object reference. Depending on the context, an
8838 -- object reference may need several conversions.
8840 if Is_Concurrent_Type (Typ) then
8842 Utyp := Corresponding_Record_Type (Typ);
8843 Ref := Convert_Concurrent (Ref, Typ);
8845 elsif Is_Private_Type (Typ)
8846 and then Present (Full_View (Typ))
8847 and then Is_Concurrent_Type (Underlying_Type (Typ))
8850 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8851 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8858 Utyp := Underlying_Type (Base_Type (Utyp));
8859 Set_Assignment_OK (Ref);
8861 -- Deal with untagged derivation of private views
8863 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
8864 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8865 Ref := Unchecked_Convert_To (Utyp, Ref);
8867 -- The following is to prevent problems with UC see 1.156 RH ???
8869 Set_Assignment_OK (Ref);
8872 -- If the underlying_type is a subtype, then we are dealing with the
8873 -- completion of a private type. We need to access the base type and
8874 -- generate a conversion to it.
8876 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8877 pragma Assert (Is_Private_Type (Typ));
8878 Utyp := Base_Type (Utyp);
8879 Ref := Unchecked_Convert_To (Utyp, Ref);
8882 -- The underlying type may not be present due to a missing full view.
8883 -- In this case freezing did not take place and there is no suitable
8884 -- [Deep_]Initialize primitive to call.
8885 -- If Typ is protected then no additional processing is needed either.
8888 or else Is_Protected_Type (Typ)
8893 -- Select the appropriate version of initialize
8895 if Has_Controlled_Component (Utyp) then
8896 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
8898 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
8899 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
8902 -- If initialization procedure for an array of controlled objects is
8903 -- trivial, do not generate a useless call to it.
8904 -- The initialization procedure may be missing altogether in the case
8905 -- of a derived container whose components have trivial initialization.
8908 or else (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
8910 (not Comes_From_Source (Proc)
8911 and then Present (Alias (Proc))
8912 and then Is_Trivial_Subprogram (Alias (Proc)))
8917 -- The object reference may need another conversion depending on the
8918 -- type of the formal and that of the actual.
8920 Ref := Convert_View (Proc, Ref);
8923 -- [Deep_]Initialize (Ref);
8926 Make_Procedure_Call_Statement (Loc,
8927 Name => New_Occurrence_Of (Proc, Loc),
8928 Parameter_Associations => New_List (Ref));
8931 ------------------------------
8932 -- Make_Local_Deep_Finalize --
8933 ------------------------------
8935 function Make_Local_Deep_Finalize
8937 Nam : Entity_Id) return Node_Id
8939 Loc : constant Source_Ptr := Sloc (Typ);
8943 Formals := New_List (
8947 Make_Parameter_Specification (Loc,
8948 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
8950 Out_Present => True,
8951 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8953 -- F : Boolean := True
8955 Make_Parameter_Specification (Loc,
8956 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
8957 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
8958 Expression => New_Occurrence_Of (Standard_True, Loc)));
8960 -- Add the necessary number of counters to represent the initialization
8961 -- state of an object.
8964 Make_Subprogram_Body (Loc,
8966 Make_Procedure_Specification (Loc,
8967 Defining_Unit_Name => Nam,
8968 Parameter_Specifications => Formals),
8970 Declarations => No_List,
8972 Handled_Statement_Sequence =>
8973 Make_Handled_Sequence_Of_Statements (Loc,
8974 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
8975 end Make_Local_Deep_Finalize;
8977 ------------------------------------
8978 -- Make_Set_Finalize_Address_Call --
8979 ------------------------------------
8981 function Make_Set_Finalize_Address_Call
8983 Ptr_Typ : Entity_Id) return Node_Id
8985 -- It is possible for Ptr_Typ to be a partial view, if the access type
8986 -- is a full view declared in the private part of a nested package, and
8987 -- the finalization actions take place when completing analysis of the
8988 -- enclosing unit. For this reason use Underlying_Type twice below.
8990 Desig_Typ : constant Entity_Id :=
8992 (Designated_Type (Underlying_Type (Ptr_Typ)));
8993 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
8994 Fin_Mas : constant Entity_Id :=
8995 Finalization_Master (Underlying_Type (Ptr_Typ));
8998 -- Both the finalization master and primitive Finalize_Address must be
9001 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
9004 -- Set_Finalize_Address
9005 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
9008 Make_Procedure_Call_Statement (Loc,
9010 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
9011 Parameter_Associations => New_List (
9012 New_Occurrence_Of (Fin_Mas, Loc),
9014 Make_Attribute_Reference (Loc,
9015 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
9016 Attribute_Name => Name_Unrestricted_Access)));
9017 end Make_Set_Finalize_Address_Call;
9019 --------------------------
9020 -- Make_Transient_Block --
9021 --------------------------
9023 function Make_Transient_Block
9026 Par : Node_Id) return Node_Id
9028 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
9029 -- Determine whether scoping entity Id manages the secondary stack
9031 function Within_Loop_Statement (N : Node_Id) return Boolean;
9032 -- Return True when N appears within a loop and no block is containing N
9034 -----------------------
9035 -- Manages_Sec_Stack --
9036 -----------------------
9038 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
9042 -- An exception handler with a choice parameter utilizes a dummy
9043 -- block to provide a declarative region. Such a block should not
9044 -- be considered because it never manifests in the tree and can
9045 -- never release the secondary stack.
9049 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
9056 return Uses_Sec_Stack (Id);
9061 end Manages_Sec_Stack;
9063 ---------------------------
9064 -- Within_Loop_Statement --
9065 ---------------------------
9067 function Within_Loop_Statement (N : Node_Id) return Boolean is
9068 Par : Node_Id := Parent (N);
9071 while Nkind (Par) not in
9072 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
9073 N_Package_Specification | N_Proper_Body
9075 pragma Assert (Present (Par));
9076 Par := Parent (Par);
9079 return Nkind (Par) = N_Loop_Statement;
9080 end Within_Loop_Statement;
9084 Decls : constant List_Id := New_List;
9085 Instrs : constant List_Id := New_List (Action);
9086 Trans_Id : constant Entity_Id := Current_Scope;
9092 -- Start of processing for Make_Transient_Block
9095 -- Even though the transient block is tasked with managing the secondary
9096 -- stack, the block may forgo this functionality depending on how the
9097 -- secondary stack is managed by enclosing scopes.
9099 if Manages_Sec_Stack (Trans_Id) then
9101 -- Determine whether an enclosing scope already manages the secondary
9104 Scop := Scope (Trans_Id);
9105 while Present (Scop) loop
9107 -- It should not be possible to reach Standard without hitting one
9108 -- of the other cases first unless Standard was manually pushed.
9110 if Scop = Standard_Standard then
9113 -- The transient block is within a function which returns on the
9114 -- secondary stack. Take a conservative approach and assume that
9115 -- the value on the secondary stack is part of the result. Note
9116 -- that it is not possible to detect this dependency without flow
9117 -- analysis which the compiler does not have. Letting the object
9118 -- live longer than the transient block will not leak any memory
9119 -- because the caller will reclaim the total storage used by the
9122 elsif Ekind (Scop) = E_Function
9123 and then Sec_Stack_Needed_For_Return (Scop)
9125 Set_Uses_Sec_Stack (Trans_Id, False);
9128 -- The transient block must manage the secondary stack when the
9129 -- block appears within a loop in order to reclaim the memory at
9132 elsif Ekind (Scop) = E_Loop then
9135 -- Ditto when the block appears without a block that does not
9136 -- manage the secondary stack and is located within a loop.
9138 elsif Ekind (Scop) = E_Block
9139 and then not Manages_Sec_Stack (Scop)
9140 and then Present (Block_Node (Scop))
9141 and then Within_Loop_Statement (Block_Node (Scop))
9145 -- The transient block does not need to manage the secondary stack
9146 -- when there is an enclosing construct which already does that.
9147 -- This optimization saves on SS_Mark and SS_Release calls but may
9148 -- allow objects to live a little longer than required.
9150 -- The transient block must manage the secondary stack when switch
9151 -- -gnatd.s (strict management) is in effect.
9153 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
9154 Set_Uses_Sec_Stack (Trans_Id, False);
9157 -- Prevent the search from going too far because transient blocks
9158 -- are bounded by packages and subprogram scopes.
9160 elsif Ekind (Scop) in E_Entry
9170 Scop := Scope (Scop);
9174 -- Create the transient block. Set the parent now since the block itself
9175 -- is not part of the tree. The current scope is the E_Block entity that
9176 -- has been pushed by Establish_Transient_Scope.
9178 pragma Assert (Ekind (Trans_Id) = E_Block);
9181 Make_Block_Statement (Loc,
9182 Identifier => New_Occurrence_Of (Trans_Id, Loc),
9183 Declarations => Decls,
9184 Handled_Statement_Sequence =>
9185 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
9186 Has_Created_Identifier => True);
9187 Set_Parent (Block, Par);
9189 -- Insert actions stuck in the transient scopes as well as all freezing
9190 -- nodes needed by those actions. Do not insert cleanup actions here,
9191 -- they will be transferred to the newly created block.
9193 Insert_Actions_In_Scope_Around
9194 (Action, Clean => False, Manage_SS => False);
9196 Insert := Prev (Action);
9198 if Present (Insert) then
9199 Freeze_All (First_Entity (Trans_Id), Insert);
9202 -- Transfer cleanup actions to the newly created block
9205 Cleanup_Actions : List_Id
9206 renames Scope_Stack.Table (Scope_Stack.Last).
9207 Actions_To_Be_Wrapped (Cleanup);
9209 Set_Cleanup_Actions (Block, Cleanup_Actions);
9210 Cleanup_Actions := No_List;
9213 -- When the transient scope was established, we pushed the entry for the
9214 -- transient scope onto the scope stack, so that the scope was active
9215 -- for the installation of finalizable entities etc. Now we must remove
9216 -- this entry, since we have constructed a proper block.
9221 end Make_Transient_Block;
9223 ------------------------
9224 -- Node_To_Be_Wrapped --
9225 ------------------------
9227 function Node_To_Be_Wrapped return Node_Id is
9229 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
9230 end Node_To_Be_Wrapped;
9232 ----------------------------
9233 -- Store_Actions_In_Scope --
9234 ----------------------------
9236 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
9237 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
9238 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
9241 if Is_Empty_List (Actions) then
9244 if Is_List_Member (SE.Node_To_Be_Wrapped) then
9245 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
9247 Set_Parent (L, SE.Node_To_Be_Wrapped);
9252 elsif AK = Before then
9253 Insert_List_After_And_Analyze (Last (Actions), L);
9256 Insert_List_Before_And_Analyze (First (Actions), L);
9258 end Store_Actions_In_Scope;
9260 ----------------------------------
9261 -- Store_After_Actions_In_Scope --
9262 ----------------------------------
9264 procedure Store_After_Actions_In_Scope (L : List_Id) is
9266 Store_Actions_In_Scope (After, L);
9267 end Store_After_Actions_In_Scope;
9269 -----------------------------------
9270 -- Store_Before_Actions_In_Scope --
9271 -----------------------------------
9273 procedure Store_Before_Actions_In_Scope (L : List_Id) is
9275 Store_Actions_In_Scope (Before, L);
9276 end Store_Before_Actions_In_Scope;
9278 -----------------------------------
9279 -- Store_Cleanup_Actions_In_Scope --
9280 -----------------------------------
9282 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
9284 Store_Actions_In_Scope (Cleanup, L);
9285 end Store_Cleanup_Actions_In_Scope;
9291 procedure Unnest_Block (Decl : Node_Id) is
9292 Loc : constant Source_Ptr := Sloc (Decl);
9294 Local_Body : Node_Id;
9295 Local_Call : Node_Id;
9296 Local_Proc : Entity_Id;
9297 Local_Scop : Entity_Id;
9300 Local_Scop := Entity (Identifier (Decl));
9301 Ent := First_Entity (Local_Scop);
9303 Local_Proc := Make_Temporary (Loc, 'P');
9306 Make_Subprogram_Body (Loc,
9308 Make_Procedure_Specification (Loc,
9309 Defining_Unit_Name => Local_Proc),
9310 Declarations => Declarations (Decl),
9311 Handled_Statement_Sequence =>
9312 Handled_Statement_Sequence (Decl));
9314 -- Handlers in the block may contain nested subprograms that require
9317 Check_Unnesting_In_Handlers (Local_Body);
9319 Rewrite (Decl, Local_Body);
9321 Set_Has_Nested_Subprogram (Local_Proc);
9324 Make_Procedure_Call_Statement (Loc,
9325 Name => New_Occurrence_Of (Local_Proc, Loc));
9327 Insert_After (Decl, Local_Call);
9328 Analyze (Local_Call);
9330 -- The new subprogram has the same scope as the original block
9332 Set_Scope (Local_Proc, Scope (Local_Scop));
9334 -- And the entity list of the new procedure is that of the block
9336 Set_First_Entity (Local_Proc, Ent);
9338 -- Reset the scopes of all the entities to the new procedure
9340 while Present (Ent) loop
9341 Set_Scope (Ent, Local_Proc);
9346 -------------------------
9347 -- Unnest_If_Statement --
9348 -------------------------
9350 procedure Unnest_If_Statement (If_Stmt : Node_Id) is
9352 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id);
9353 -- A list of statements (that may be a list associated with a then,
9354 -- elsif, or else part of an if-statement) is traversed at the top
9355 -- level to determine whether it contains a subprogram body, and if so,
9356 -- the statements will be replaced with a new procedure body containing
9357 -- the statements followed by a call to the procedure. The individual
9358 -- statements may also be blocks, loops, or other if statements that
9359 -- themselves may require contain nested subprograms needing unnesting.
9361 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is
9362 Subp_Found : Boolean := False;
9365 if Is_Empty_List (Stmts) then
9370 Stmt : Node_Id := First (Stmts);
9372 while Present (Stmt) loop
9373 if Nkind (Stmt) = N_Subprogram_Body then
9382 -- The statements themselves may be blocks, loops, etc. that in turn
9383 -- contain nested subprograms requiring an unnesting transformation.
9384 -- We perform this traversal after looking for subprogram bodies, to
9385 -- avoid considering procedures created for one of those statements
9386 -- (such as a block rewritten as a procedure) as a nested subprogram
9387 -- of the statement list (which could result in an unneeded wrapper
9390 Check_Unnesting_In_Decls_Or_Stmts (Stmts);
9392 -- If there was a top-level subprogram body in the statement list,
9393 -- then perform an unnesting transformation on the list by replacing
9394 -- the statements with a wrapper procedure body containing the
9395 -- original statements followed by a call to that procedure.
9398 Unnest_Statement_List (Stmts);
9400 end Check_Stmts_For_Subp_Unnesting;
9404 Then_Stmts : List_Id := Then_Statements (If_Stmt);
9405 Else_Stmts : List_Id := Else_Statements (If_Stmt);
9407 -- Start of processing for Unnest_If_Statement
9410 Check_Stmts_For_Subp_Unnesting (Then_Stmts);
9411 Set_Then_Statements (If_Stmt, Then_Stmts);
9413 if not Is_Empty_List (Elsif_Parts (If_Stmt)) then
9415 Elsif_Part : Node_Id :=
9416 First (Elsif_Parts (If_Stmt));
9417 Elsif_Stmts : List_Id;
9419 while Present (Elsif_Part) loop
9420 Elsif_Stmts := Then_Statements (Elsif_Part);
9422 Check_Stmts_For_Subp_Unnesting (Elsif_Stmts);
9423 Set_Then_Statements (Elsif_Part, Elsif_Stmts);
9430 Check_Stmts_For_Subp_Unnesting (Else_Stmts);
9431 Set_Else_Statements (If_Stmt, Else_Stmts);
9432 end Unnest_If_Statement;
9438 procedure Unnest_Loop (Loop_Stmt : Node_Id) is
9439 Loc : constant Source_Ptr := Sloc (Loop_Stmt);
9441 Local_Body : Node_Id;
9442 Local_Call : Node_Id;
9443 Local_Proc : Entity_Id;
9444 Local_Scop : Entity_Id;
9445 Loop_Copy : constant Node_Id :=
9446 Relocate_Node (Loop_Stmt);
9448 Local_Scop := Entity (Identifier (Loop_Stmt));
9449 Ent := First_Entity (Local_Scop);
9451 Local_Proc := Make_Temporary (Loc, 'P');
9454 Make_Subprogram_Body (Loc,
9456 Make_Procedure_Specification (Loc,
9457 Defining_Unit_Name => Local_Proc),
9458 Declarations => Empty_List,
9459 Handled_Statement_Sequence =>
9460 Make_Handled_Sequence_Of_Statements (Loc,
9461 Statements => New_List (Loop_Copy)));
9463 Rewrite (Loop_Stmt, Local_Body);
9464 Analyze (Loop_Stmt);
9466 Set_Has_Nested_Subprogram (Local_Proc);
9469 Make_Procedure_Call_Statement (Loc,
9470 Name => New_Occurrence_Of (Local_Proc, Loc));
9472 Insert_After (Loop_Stmt, Local_Call);
9473 Analyze (Local_Call);
9475 -- New procedure has the same scope as the original loop, and the scope
9476 -- of the loop is the new procedure.
9478 Set_Scope (Local_Proc, Scope (Local_Scop));
9479 Set_Scope (Local_Scop, Local_Proc);
9481 -- The entity list of the new procedure is that of the loop
9483 Set_First_Entity (Local_Proc, Ent);
9485 -- Note that the entities associated with the loop don't need to have
9486 -- their Scope fields reset, since they're still associated with the
9487 -- same loop entity that now belongs to the copied loop statement.
9490 ---------------------------
9491 -- Unnest_Statement_List --
9492 ---------------------------
9494 procedure Unnest_Statement_List (Stmts : in out List_Id) is
9495 Loc : constant Source_Ptr := Sloc (First (Stmts));
9496 Local_Body : Node_Id;
9497 Local_Call : Node_Id;
9498 Local_Proc : Entity_Id;
9499 New_Stmts : constant List_Id := Empty_List;
9502 Local_Proc := Make_Temporary (Loc, 'P');
9505 Make_Subprogram_Body (Loc,
9507 Make_Procedure_Specification (Loc,
9508 Defining_Unit_Name => Local_Proc),
9509 Declarations => Empty_List,
9510 Handled_Statement_Sequence =>
9511 Make_Handled_Sequence_Of_Statements (Loc,
9512 Statements => Stmts));
9514 Append_To (New_Stmts, Local_Body);
9516 Analyze (Local_Body);
9518 Set_Has_Nested_Subprogram (Local_Proc);
9521 Make_Procedure_Call_Statement (Loc,
9522 Name => New_Occurrence_Of (Local_Proc, Loc));
9524 Append_To (New_Stmts, Local_Call);
9525 Analyze (Local_Call);
9527 -- Traverse the statements, and for any that are declarations or
9528 -- subprogram bodies that have entities, set the Scope of those
9529 -- entities to the new procedure's Entity_Id.
9532 Stmt : Node_Id := First (Stmts);
9535 while Present (Stmt) loop
9536 case Nkind (Stmt) is
9538 | N_Renaming_Declaration
9540 Set_Scope (Defining_Identifier (Stmt), Local_Proc);
9542 when N_Subprogram_Body =>
9544 (Defining_Unit_Name (Specification (Stmt)), Local_Proc);
9555 end Unnest_Statement_List;
9557 --------------------------------
9558 -- Wrap_Transient_Declaration --
9559 --------------------------------
9561 -- If a transient scope has been established during the processing of the
9562 -- Expression of an Object_Declaration, it is not possible to wrap the
9563 -- declaration into a transient block as usual case, otherwise the object
9564 -- would be itself declared in the wrong scope. Therefore, all entities (if
9565 -- any) defined in the transient block are moved to the proper enclosing
9566 -- scope. Furthermore, if they are controlled variables they are finalized
9567 -- right after the declaration. The finalization list of the transient
9568 -- scope is defined as a renaming of the enclosing one so during their
9569 -- initialization they will be attached to the proper finalization list.
9570 -- For instance, the following declaration :
9572 -- X : Typ := F (G (A), G (B));
9574 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9575 -- is expanded into :
9577 -- X : Typ := [ complex Expression-Action ];
9578 -- [Deep_]Finalize (_v1);
9579 -- [Deep_]Finalize (_v2);
9581 procedure Wrap_Transient_Declaration (N : Node_Id) is
9586 Curr_S := Current_Scope;
9587 Encl_S := Scope (Curr_S);
9589 -- Insert all actions including cleanup generated while analyzing or
9590 -- expanding the transient context back into the tree. Manage the
9591 -- secondary stack when the object declaration appears in a library
9592 -- level package [body].
9594 Insert_Actions_In_Scope_Around
9598 Uses_Sec_Stack (Curr_S)
9599 and then Nkind (N) = N_Object_Declaration
9600 and then Ekind (Encl_S) in E_Package | E_Package_Body
9601 and then Is_Library_Level_Entity (Encl_S));
9604 -- Relocate local entities declared within the transient scope to the
9605 -- enclosing scope. This action sets their Is_Public flag accordingly.
9607 Transfer_Entities (Curr_S, Encl_S);
9609 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9610 -- is properly released upon exiting the said scope.
9612 if Uses_Sec_Stack (Curr_S) then
9613 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
9615 -- Do not mark a function that returns on the secondary stack as the
9616 -- reclamation is done by the caller.
9618 if Ekind (Curr_S) = E_Function
9619 and then Needs_Secondary_Stack (Etype (Curr_S))
9623 -- Otherwise mark the enclosing dynamic scope
9626 Set_Uses_Sec_Stack (Curr_S);
9627 Check_Restriction (No_Secondary_Stack, N);
9630 end Wrap_Transient_Declaration;
9632 -------------------------------
9633 -- Wrap_Transient_Expression --
9634 -------------------------------
9636 procedure Wrap_Transient_Expression (N : Node_Id) is
9637 Loc : constant Source_Ptr := Sloc (N);
9638 Expr : Node_Id := Relocate_Node (N);
9639 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
9640 Typ : constant Entity_Id := Etype (N);
9647 -- M : constant Mark_Id := SS_Mark;
9648 -- procedure Finalizer is ... (See Build_Finalizer)
9651 -- Temp := <Expr>; -- general case
9652 -- Temp := (if <Expr> then True else False); -- boolean case
9658 -- A special case is made for Boolean expressions so that the back end
9659 -- knows to generate a conditional branch instruction, if running with
9660 -- -fpreserve-control-flow. This ensures that a control-flow change
9661 -- signaling the decision outcome occurs before the cleanup actions.
9663 if Opt.Suppress_Control_Flow_Optimizations
9664 and then Is_Boolean_Type (Typ)
9667 Make_If_Expression (Loc,
9668 Expressions => New_List (
9670 New_Occurrence_Of (Standard_True, Loc),
9671 New_Occurrence_Of (Standard_False, Loc)));
9674 Insert_Actions (N, New_List (
9675 Make_Object_Declaration (Loc,
9676 Defining_Identifier => Temp,
9677 Object_Definition => New_Occurrence_Of (Typ, Loc)),
9679 Make_Transient_Block (Loc,
9681 Make_Assignment_Statement (Loc,
9682 Name => New_Occurrence_Of (Temp, Loc),
9683 Expression => Expr),
9684 Par => Parent (N))));
9686 if Debug_Generated_Code then
9687 Set_Debug_Info_Needed (Temp);
9690 Rewrite (N, New_Occurrence_Of (Temp, Loc));
9691 Analyze_And_Resolve (N, Typ);
9692 end Wrap_Transient_Expression;
9694 ------------------------------
9695 -- Wrap_Transient_Statement --
9696 ------------------------------
9698 procedure Wrap_Transient_Statement (N : Node_Id) is
9699 Loc : constant Source_Ptr := Sloc (N);
9700 New_Stmt : constant Node_Id := Relocate_Node (N);
9705 -- M : constant Mark_Id := SS_Mark;
9706 -- procedure Finalizer is ... (See Build_Finalizer)
9716 Make_Transient_Block (Loc,
9718 Par => Parent (N)));
9720 -- With the scope stack back to normal, we can call analyze on the
9721 -- resulting block. At this point, the transient scope is being
9722 -- treated like a perfectly normal scope, so there is nothing
9723 -- special about it.
9725 -- Note: Wrap_Transient_Statement is called with the node already
9726 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9727 -- otherwise we would get a recursive processing of the node when
9728 -- we do this Analyze call.
9731 end Wrap_Transient_Statement;