Daily bump.
[official-gcc.git] / gcc / ada / exp_ch7.adb
blobe669454243431dff50e92ee224d39a31842cac57
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 7 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
27 -- - controlled types
28 -- - transient scopes
30 with Atree; use Atree;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Ch11; use Exp_Ch11;
38 with Exp_Dbug; use Exp_Dbug;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Disp; use Exp_Disp;
41 with Exp_Prag; use Exp_Prag;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
45 with Lib; use Lib;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
48 with Opt; use Opt;
49 with Output; use Output;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
53 with Sinfo; use Sinfo;
54 with Sem; use Sem;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch7; use Sem_Ch7;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Res; use Sem_Res;
60 with Sem_Util; use Sem_Util;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Tbuild; use Tbuild;
64 with Ttypes; use Ttypes;
65 with Uintp; use Uintp;
67 package body Exp_Ch7 is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
89 -- for details.
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
104 -- function result.
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
117 -- anyway.
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
122 -- a tagged type.
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
129 -- N is a node which may generate a transient scope. Loop over the parent
130 -- pointers of N until we find the appropriate node to wrap. If it returns
131 -- Empty, it means that no transient scope is needed in this context.
133 procedure Insert_Actions_In_Scope_Around
134 (N : Node_Id;
135 Clean : Boolean;
136 Manage_SS : Boolean);
137 -- Insert the before-actions kept in the scope stack before N, and the
138 -- after-actions after N, which must be a member of a list. If flag Clean
139 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
140 -- calls to mark and release the secondary stack.
142 function Make_Transient_Block
143 (Loc : Source_Ptr;
144 Action : Node_Id;
145 Par : Node_Id) return Node_Id;
146 -- Action is a single statement or object declaration. Par is the proper
147 -- parent of the generated block. Create a transient block whose name is
148 -- the current scope and the only handled statement is Action. If Action
149 -- involves controlled objects or secondary stack usage, the corresponding
150 -- cleanup actions are performed at the end of the block.
152 procedure Set_Node_To_Be_Wrapped (N : Node_Id);
153 -- Set the field Node_To_Be_Wrapped of the current scope
155 -- ??? The entire comment needs to be rewritten
156 -- ??? which entire comment?
158 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
159 -- Shared processing for Store_xxx_Actions_In_Scope
161 -----------------------------
162 -- Finalization Management --
163 -----------------------------
165 -- This part describe how Initialization/Adjustment/Finalization procedures
166 -- are generated and called. Two cases must be considered, types that are
167 -- Controlled (Is_Controlled flag set) and composite types that contain
168 -- controlled components (Has_Controlled_Component flag set). In the first
169 -- case the procedures to call are the user-defined primitive operations
170 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
171 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
172 -- of calling the former procedures on the controlled components.
174 -- For records with Has_Controlled_Component set, a hidden "controller"
175 -- component is inserted. This controller component contains its own
176 -- finalization list on which all controlled components are attached
177 -- creating an indirection on the upper-level Finalization list. This
178 -- technique facilitates the management of objects whose number of
179 -- controlled components changes during execution. This controller
180 -- component is itself controlled and is attached to the upper-level
181 -- finalization chain. Its adjust primitive is in charge of calling adjust
182 -- on the components and adjusting the finalization pointer to match their
183 -- new location (see a-finali.adb).
185 -- It is not possible to use a similar technique for arrays that have
186 -- Has_Controlled_Component set. In this case, deep procedures are
187 -- generated that call initialize/adjust/finalize + attachment or
188 -- detachment on the finalization list for all component.
190 -- Initialize calls: they are generated for declarations or dynamic
191 -- allocations of Controlled objects with no initial value. They are always
192 -- followed by an attachment to the current Finalization Chain. For the
193 -- dynamic allocation case this the chain attached to the scope of the
194 -- access type definition otherwise, this is the chain of the current
195 -- scope.
197 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
198 -- or dynamic allocations of Controlled objects with an initial value.
199 -- (2) after an assignment. In the first case they are followed by an
200 -- attachment to the final chain, in the second case they are not.
202 -- Finalization Calls: They are generated on (1) scope exit, (2)
203 -- assignments, (3) unchecked deallocations. In case (3) they have to
204 -- be detached from the final chain, in case (2) they must not and in
205 -- case (1) this is not important since we are exiting the scope anyway.
207 -- Other details:
209 -- Type extensions will have a new record controller at each derivation
210 -- level containing controlled components. The record controller for
211 -- the parent/ancestor is attached to the finalization list of the
212 -- extension's record controller (i.e. the parent is like a component
213 -- of the extension).
215 -- For types that are both Is_Controlled and Has_Controlled_Components,
216 -- the record controller and the object itself are handled separately.
217 -- It could seem simpler to attach the object at the end of its record
218 -- controller but this would not tackle view conversions properly.
220 -- A classwide type can always potentially have controlled components
221 -- but the record controller of the corresponding actual type may not
222 -- be known at compile time so the dispatch table contains a special
223 -- field that allows computation of the offset of the record controller
224 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
226 -- Here is a simple example of the expansion of a controlled block :
228 -- declare
229 -- X : Controlled;
230 -- Y : Controlled := Init;
232 -- type R is record
233 -- C : Controlled;
234 -- end record;
235 -- W : R;
236 -- Z : R := (C => X);
238 -- begin
239 -- X := Y;
240 -- W := Z;
241 -- end;
243 -- is expanded into
245 -- declare
246 -- _L : System.FI.Finalizable_Ptr;
248 -- procedure _Clean is
249 -- begin
250 -- Abort_Defer;
251 -- System.FI.Finalize_List (_L);
252 -- Abort_Undefer;
253 -- end _Clean;
255 -- X : Controlled;
256 -- begin
257 -- Abort_Defer;
258 -- Initialize (X);
259 -- Attach_To_Final_List (_L, Finalizable (X), 1);
260 -- at end: Abort_Undefer;
261 -- Y : Controlled := Init;
262 -- Adjust (Y);
263 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
265 -- type R is record
266 -- C : Controlled;
267 -- end record;
268 -- W : R;
269 -- begin
270 -- Abort_Defer;
271 -- Deep_Initialize (W, _L, 1);
272 -- at end: Abort_Under;
273 -- Z : R := (C => X);
274 -- Deep_Adjust (Z, _L, 1);
276 -- begin
277 -- _Assign (X, Y);
278 -- Deep_Finalize (W, False);
279 -- <save W's final pointers>
280 -- W := Z;
281 -- <restore W's final pointers>
282 -- Deep_Adjust (W, _L, 0);
283 -- at end
284 -- _Clean;
285 -- end;
287 type Final_Primitives is
288 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
289 -- This enumeration type is defined in order to ease sharing code for
290 -- building finalization procedures for composite types.
292 Name_Of : constant array (Final_Primitives) of Name_Id :=
293 (Initialize_Case => Name_Initialize,
294 Adjust_Case => Name_Adjust,
295 Finalize_Case => Name_Finalize,
296 Address_Case => Name_Finalize_Address);
297 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
298 (Initialize_Case => TSS_Deep_Initialize,
299 Adjust_Case => TSS_Deep_Adjust,
300 Finalize_Case => TSS_Deep_Finalize,
301 Address_Case => TSS_Finalize_Address);
303 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
304 -- Determine whether access type Typ may have a finalization master
306 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
307 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
308 -- Has_Controlled_Component set and store them using the TSS mechanism.
310 function Build_Cleanup_Statements
311 (N : Node_Id;
312 Additional_Cleanup : List_Id) return List_Id;
313 -- Create the cleanup calls for an asynchronous call block, task master,
314 -- protected subprogram body, task allocation block or task body, or
315 -- additional cleanup actions parked on a transient block. If the context
316 -- does not contain the above constructs, the routine returns an empty
317 -- list.
319 procedure Build_Finalizer
320 (N : Node_Id;
321 Clean_Stmts : List_Id;
322 Mark_Id : Entity_Id;
323 Top_Decls : List_Id;
324 Defer_Abort : Boolean;
325 Fin_Id : out Entity_Id);
326 -- N may denote an accept statement, block, entry body, package body,
327 -- package spec, protected body, subprogram body, or a task body. Create
328 -- a procedure which contains finalization calls for all controlled objects
329 -- declared in the declarative or statement region of N. The calls are
330 -- built in reverse order relative to the original declarations. In the
331 -- case of a task body, the routine delays the creation of the finalizer
332 -- until all statements have been moved to the task body procedure.
333 -- Clean_Stmts may contain additional context-dependent code used to abort
334 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
335 -- Mark_Id is the secondary stack used in the current context or Empty if
336 -- missing. Top_Decls is the list on which the declaration of the finalizer
337 -- is attached in the non-package case. Defer_Abort indicates that the
338 -- statements passed in perform actions that require abort to be deferred,
339 -- such as for task termination. Fin_Id is the finalizer declaration
340 -- entity.
342 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
343 -- N is a construct which contains a handled sequence of statements, Fin_Id
344 -- is the entity of a finalizer. Create an At_End handler which covers the
345 -- statements of N and calls Fin_Id. If the handled statement sequence has
346 -- an exception handler, the statements will be wrapped in a block to avoid
347 -- unwanted interaction with the new At_End handler.
349 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
350 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
351 -- Has_Component_Component set and store them using the TSS mechanism.
353 procedure Check_Visibly_Controlled
354 (Prim : Final_Primitives;
355 Typ : Entity_Id;
356 E : in out Entity_Id;
357 Cref : in out Node_Id);
358 -- The controlled operation declared for a derived type may not be
359 -- overriding, if the controlled operations of the parent type are hidden,
360 -- for example when the parent is a private type whose full view is
361 -- controlled. For other primitive operations we modify the name of the
362 -- operation to indicate that it is not overriding, but this is not
363 -- possible for Initialize, etc. because they have to be retrievable by
364 -- name. Before generating the proper call to one of these operations we
365 -- check whether Typ is known to be controlled at the point of definition.
366 -- If it is not then we must retrieve the hidden operation of the parent
367 -- and use it instead. This is one case that might be solved more cleanly
368 -- once Overriding pragmas or declarations are in place.
370 function Convert_View
371 (Proc : Entity_Id;
372 Arg : Node_Id;
373 Ind : Pos := 1) return Node_Id;
374 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
375 -- argument being passed to it. Ind indicates which formal of procedure
376 -- Proc we are trying to match. This function will, if necessary, generate
377 -- a conversion between the partial and full view of Arg to match the type
378 -- of the formal of Proc, or force a conversion to the class-wide type in
379 -- the case where the operation is abstract.
381 function Enclosing_Function (E : Entity_Id) return Entity_Id;
382 -- Given an arbitrary entity, traverse the scope chain looking for the
383 -- first enclosing function. Return Empty if no function was found.
385 function Make_Call
386 (Loc : Source_Ptr;
387 Proc_Id : Entity_Id;
388 Param : Node_Id;
389 Skip_Self : Boolean := False) return Node_Id;
390 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
391 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
392 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
393 -- action has an effect on the components only (if any).
395 function Make_Deep_Proc
396 (Prim : Final_Primitives;
397 Typ : Entity_Id;
398 Stmts : List_Id) return Node_Id;
399 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
400 -- Deep_Finalize procedures according to the first parameter, these
401 -- procedures operate on the type Typ. The Stmts parameter gives the body
402 -- of the procedure.
404 function Make_Deep_Array_Body
405 (Prim : Final_Primitives;
406 Typ : Entity_Id) return List_Id;
407 -- This function generates the list of statements for implementing
408 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
409 -- the first parameter, these procedures operate on the array type Typ.
411 function Make_Deep_Record_Body
412 (Prim : Final_Primitives;
413 Typ : Entity_Id;
414 Is_Local : Boolean := False) return List_Id;
415 -- This function generates the list of statements for implementing
416 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
417 -- the first parameter, these procedures operate on the record type Typ.
418 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
419 -- whether the inner logic should be dictated by state counters.
421 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
422 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
423 -- Make_Deep_Record_Body. Generate the following statements:
425 -- declare
426 -- type Acc_Typ is access all Typ;
427 -- for Acc_Typ'Storage_Size use 0;
428 -- begin
429 -- [Deep_]Finalize (Acc_Typ (V).all);
430 -- end;
432 --------------------------------
433 -- Allows_Finalization_Master --
434 --------------------------------
436 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
437 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
438 -- Determine whether entity E is inside a wrapper package created for
439 -- an instance of Ada.Unchecked_Deallocation.
441 ------------------------------
442 -- In_Deallocation_Instance --
443 ------------------------------
445 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
446 Pkg : constant Entity_Id := Scope (E);
447 Par : Node_Id := Empty;
449 begin
450 if Ekind (Pkg) = E_Package
451 and then Present (Related_Instance (Pkg))
452 and then Ekind (Related_Instance (Pkg)) = E_Procedure
453 then
454 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
456 return
457 Present (Par)
458 and then Chars (Par) = Name_Unchecked_Deallocation
459 and then Chars (Scope (Par)) = Name_Ada
460 and then Scope (Scope (Par)) = Standard_Standard;
461 end if;
463 return False;
464 end In_Deallocation_Instance;
466 -- Local variables
468 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
469 Ptr_Typ : constant Entity_Id :=
470 Root_Type_Of_Full_View (Base_Type (Typ));
472 -- Start of processing for Allows_Finalization_Master
474 begin
475 -- Certain run-time configurations and targets do not provide support
476 -- for controlled types and therefore do not need masters.
478 if Restriction_Active (No_Finalization) then
479 return False;
481 -- Do not consider C and C++ types since it is assumed that the non-Ada
482 -- side will handle their cleanup.
484 elsif Convention (Desig_Typ) = Convention_C
485 or else Convention (Desig_Typ) = Convention_CPP
486 then
487 return False;
489 -- Do not consider an access type that returns on the secondary stack
491 elsif Present (Associated_Storage_Pool (Ptr_Typ))
492 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
493 then
494 return False;
496 -- Do not consider an access type that can never allocate an object
498 elsif No_Pool_Assigned (Ptr_Typ) then
499 return False;
501 -- Do not consider an access type coming from an Unchecked_Deallocation
502 -- instance. Even though the designated type may be controlled, the
503 -- access type will never participate in any allocations.
505 elsif In_Deallocation_Instance (Ptr_Typ) then
506 return False;
508 -- Do not consider a non-library access type when No_Nested_Finalization
509 -- is in effect since finalization masters are controlled objects and if
510 -- created will violate the restriction.
512 elsif Restriction_Active (No_Nested_Finalization)
513 and then not Is_Library_Level_Entity (Ptr_Typ)
514 then
515 return False;
517 -- Do not consider an access type subject to pragma No_Heap_Finalization
518 -- because objects allocated through such a type are not to be finalized
519 -- when the access type goes out of scope.
521 elsif No_Heap_Finalization (Ptr_Typ) then
522 return False;
524 -- Do not create finalization masters in GNATprove mode because this
525 -- causes unwanted extra expansion. A compilation in this mode must
526 -- keep the tree as close as possible to the original sources.
528 elsif GNATprove_Mode then
529 return False;
531 -- Otherwise the access type may use a finalization master
533 else
534 return True;
535 end if;
536 end Allows_Finalization_Master;
538 ----------------------------
539 -- Build_Anonymous_Master --
540 ----------------------------
542 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
543 function Create_Anonymous_Master
544 (Desig_Typ : Entity_Id;
545 Unit_Id : Entity_Id;
546 Unit_Decl : Node_Id) return Entity_Id;
547 -- Create a new anonymous master for access type Ptr_Typ with designated
548 -- type Desig_Typ. The declaration of the master and its initialization
549 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
550 -- the entity of Unit_Decl.
552 function Current_Anonymous_Master
553 (Desig_Typ : Entity_Id;
554 Unit_Id : Entity_Id) return Entity_Id;
555 -- Find an anonymous master declared within unit Unit_Id which services
556 -- designated type Desig_Typ. If there is no such master, return Empty.
558 -----------------------------
559 -- Create_Anonymous_Master --
560 -----------------------------
562 function Create_Anonymous_Master
563 (Desig_Typ : Entity_Id;
564 Unit_Id : Entity_Id;
565 Unit_Decl : Node_Id) return Entity_Id
567 Loc : constant Source_Ptr := Sloc (Unit_Id);
569 All_FMs : Elist_Id;
570 Decls : List_Id;
571 FM_Decl : Node_Id;
572 FM_Id : Entity_Id;
573 FM_Init : Node_Id;
574 Unit_Spec : Node_Id;
576 begin
577 -- Generate:
578 -- <FM_Id> : Finalization_Master;
580 FM_Id := Make_Temporary (Loc, 'A');
582 FM_Decl :=
583 Make_Object_Declaration (Loc,
584 Defining_Identifier => FM_Id,
585 Object_Definition =>
586 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
588 -- Generate:
589 -- Set_Base_Pool
590 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
592 FM_Init :=
593 Make_Procedure_Call_Statement (Loc,
594 Name =>
595 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
596 Parameter_Associations => New_List (
597 New_Occurrence_Of (FM_Id, Loc),
598 Make_Attribute_Reference (Loc,
599 Prefix =>
600 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
601 Attribute_Name => Name_Unrestricted_Access)));
603 -- Find the declarative list of the unit
605 if Nkind (Unit_Decl) = N_Package_Declaration then
606 Unit_Spec := Specification (Unit_Decl);
607 Decls := Visible_Declarations (Unit_Spec);
609 if No (Decls) then
610 Decls := New_List;
611 Set_Visible_Declarations (Unit_Spec, Decls);
612 end if;
614 -- Package body or subprogram case
616 -- ??? A subprogram spec or body that acts as a compilation unit may
617 -- contain a formal parameter of an anonymous access-to-controlled
618 -- type initialized by an allocator.
620 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
622 -- There is no suitable place to create the master as the subprogram
623 -- is not in a declarative list.
625 else
626 Decls := Declarations (Unit_Decl);
628 if No (Decls) then
629 Decls := New_List;
630 Set_Declarations (Unit_Decl, Decls);
631 end if;
632 end if;
634 Prepend_To (Decls, FM_Init);
635 Prepend_To (Decls, FM_Decl);
637 -- Use the scope of the unit when analyzing the declaration of the
638 -- master and its initialization actions.
640 Push_Scope (Unit_Id);
641 Analyze (FM_Decl);
642 Analyze (FM_Init);
643 Pop_Scope;
645 -- Mark the master as servicing this specific designated type
647 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
649 -- Include the anonymous master in the list of existing masters which
650 -- appear in this unit. This effectively creates a mapping between a
651 -- master and a designated type which in turn allows for the reuse of
652 -- masters on a per-unit basis.
654 All_FMs := Anonymous_Masters (Unit_Id);
656 if No (All_FMs) then
657 All_FMs := New_Elmt_List;
658 Set_Anonymous_Masters (Unit_Id, All_FMs);
659 end if;
661 Prepend_Elmt (FM_Id, All_FMs);
663 return FM_Id;
664 end Create_Anonymous_Master;
666 ------------------------------
667 -- Current_Anonymous_Master --
668 ------------------------------
670 function Current_Anonymous_Master
671 (Desig_Typ : Entity_Id;
672 Unit_Id : Entity_Id) return Entity_Id
674 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
675 FM_Elmt : Elmt_Id;
676 FM_Id : Entity_Id;
678 begin
679 -- Inspect the list of anonymous masters declared within the unit
680 -- looking for an existing master which services the same designated
681 -- type.
683 if Present (All_FMs) then
684 FM_Elmt := First_Elmt (All_FMs);
685 while Present (FM_Elmt) loop
686 FM_Id := Node (FM_Elmt);
688 -- The currect master services the same designated type. As a
689 -- result the master can be reused and associated with another
690 -- anonymous access-to-controlled type.
692 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
693 return FM_Id;
694 end if;
696 Next_Elmt (FM_Elmt);
697 end loop;
698 end if;
700 return Empty;
701 end Current_Anonymous_Master;
703 -- Local variables
705 Desig_Typ : Entity_Id;
706 FM_Id : Entity_Id;
707 Priv_View : Entity_Id;
708 Unit_Decl : Node_Id;
709 Unit_Id : Entity_Id;
711 -- Start of processing for Build_Anonymous_Master
713 begin
714 -- Nothing to do if the circumstances do not allow for a finalization
715 -- master.
717 if not Allows_Finalization_Master (Ptr_Typ) then
718 return;
719 end if;
721 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
722 Unit_Id := Unique_Defining_Entity (Unit_Decl);
724 -- The compilation unit is a package instantiation. In this case the
725 -- anonymous master is associated with the package spec as both the
726 -- spec and body appear at the same level.
728 if Nkind (Unit_Decl) = N_Package_Body
729 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
730 then
731 Unit_Id := Corresponding_Spec (Unit_Decl);
732 Unit_Decl := Unit_Declaration_Node (Unit_Id);
733 end if;
735 -- Use the initial declaration of the designated type when it denotes
736 -- the full view of an incomplete or private type. This ensures that
737 -- types with one and two views are treated the same.
739 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
740 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
742 if Present (Priv_View) then
743 Desig_Typ := Priv_View;
744 end if;
746 -- Determine whether the current semantic unit already has an anonymous
747 -- master which services the designated type.
749 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
751 -- If this is not the case, create a new master
753 if No (FM_Id) then
754 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
755 end if;
757 Set_Finalization_Master (Ptr_Typ, FM_Id);
758 end Build_Anonymous_Master;
760 ----------------------------
761 -- Build_Array_Deep_Procs --
762 ----------------------------
764 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
765 begin
766 Set_TSS (Typ,
767 Make_Deep_Proc
768 (Prim => Initialize_Case,
769 Typ => Typ,
770 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
772 if not Is_Limited_View (Typ) then
773 Set_TSS (Typ,
774 Make_Deep_Proc
775 (Prim => Adjust_Case,
776 Typ => Typ,
777 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
778 end if;
780 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
781 -- suppressed since these routine will not be used.
783 if not Restriction_Active (No_Finalization) then
784 Set_TSS (Typ,
785 Make_Deep_Proc
786 (Prim => Finalize_Case,
787 Typ => Typ,
788 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
790 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
792 if not CodePeer_Mode then
793 Set_TSS (Typ,
794 Make_Deep_Proc
795 (Prim => Address_Case,
796 Typ => Typ,
797 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
798 end if;
799 end if;
800 end Build_Array_Deep_Procs;
802 ------------------------------
803 -- Build_Cleanup_Statements --
804 ------------------------------
806 function Build_Cleanup_Statements
807 (N : Node_Id;
808 Additional_Cleanup : List_Id) return List_Id
810 Is_Asynchronous_Call : constant Boolean :=
811 Nkind (N) = N_Block_Statement
812 and then Is_Asynchronous_Call_Block (N);
813 Is_Master : constant Boolean :=
814 Nkind (N) /= N_Entry_Body
815 and then Is_Task_Master (N);
816 Is_Protected_Body : constant Boolean :=
817 Nkind (N) = N_Subprogram_Body
818 and then Is_Protected_Subprogram_Body (N);
819 Is_Task_Allocation : constant Boolean :=
820 Nkind (N) = N_Block_Statement
821 and then Is_Task_Allocation_Block (N);
822 Is_Task_Body : constant Boolean :=
823 Nkind (Original_Node (N)) = N_Task_Body;
825 Loc : constant Source_Ptr := Sloc (N);
826 Stmts : constant List_Id := New_List;
828 begin
829 if Is_Task_Body then
830 if Restricted_Profile then
831 Append_To (Stmts,
832 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
833 else
834 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
835 end if;
837 elsif Is_Master then
838 if Restriction_Active (No_Task_Hierarchy) = False then
839 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
840 end if;
842 -- Add statements to unlock the protected object parameter and to
843 -- undefer abort. If the context is a protected procedure and the object
844 -- has entries, call the entry service routine.
846 -- NOTE: The generated code references _object, a parameter to the
847 -- procedure.
849 elsif Is_Protected_Body then
850 declare
851 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
852 Conc_Typ : Entity_Id;
853 Param : Node_Id;
854 Param_Typ : Entity_Id;
856 begin
857 -- Find the _object parameter representing the protected object
859 Param := First (Parameter_Specifications (Spec));
860 loop
861 Param_Typ := Etype (Parameter_Type (Param));
863 if Ekind (Param_Typ) = E_Record_Type then
864 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
865 end if;
867 exit when No (Param) or else Present (Conc_Typ);
868 Next (Param);
869 end loop;
871 pragma Assert (Present (Param));
873 -- Historical note: In earlier versions of GNAT, there was code
874 -- at this point to generate stuff to service entry queues. It is
875 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
877 Build_Protected_Subprogram_Call_Cleanup
878 (Specification (N), Conc_Typ, Loc, Stmts);
879 end;
881 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
882 -- tasks. Other unactivated tasks are completed by Complete_Task or
883 -- Complete_Master.
885 -- NOTE: The generated code references _chain, a local object
887 elsif Is_Task_Allocation then
889 -- Generate:
890 -- Expunge_Unactivated_Tasks (_chain);
892 -- where _chain is the list of tasks created by the allocator but not
893 -- yet activated. This list will be empty unless the block completes
894 -- abnormally.
896 Append_To (Stmts,
897 Make_Procedure_Call_Statement (Loc,
898 Name =>
899 New_Occurrence_Of
900 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
901 Parameter_Associations => New_List (
902 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
904 -- Attempt to cancel an asynchronous entry call whenever the block which
905 -- contains the abortable part is exited.
907 -- NOTE: The generated code references Cnn, a local object
909 elsif Is_Asynchronous_Call then
910 declare
911 Cancel_Param : constant Entity_Id :=
912 Entry_Cancel_Parameter (Entity (Identifier (N)));
914 begin
915 -- If it is of type Communication_Block, this must be a protected
916 -- entry call. Generate:
918 -- if Enqueued (Cancel_Param) then
919 -- Cancel_Protected_Entry_Call (Cancel_Param);
920 -- end if;
922 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
923 Append_To (Stmts,
924 Make_If_Statement (Loc,
925 Condition =>
926 Make_Function_Call (Loc,
927 Name =>
928 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
929 Parameter_Associations => New_List (
930 New_Occurrence_Of (Cancel_Param, Loc))),
932 Then_Statements => New_List (
933 Make_Procedure_Call_Statement (Loc,
934 Name =>
935 New_Occurrence_Of
936 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
937 Parameter_Associations => New_List (
938 New_Occurrence_Of (Cancel_Param, Loc))))));
940 -- Asynchronous delay, generate:
941 -- Cancel_Async_Delay (Cancel_Param);
943 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
944 Append_To (Stmts,
945 Make_Procedure_Call_Statement (Loc,
946 Name =>
947 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
948 Parameter_Associations => New_List (
949 Make_Attribute_Reference (Loc,
950 Prefix =>
951 New_Occurrence_Of (Cancel_Param, Loc),
952 Attribute_Name => Name_Unchecked_Access))));
954 -- Task entry call, generate:
955 -- Cancel_Task_Entry_Call (Cancel_Param);
957 else
958 Append_To (Stmts,
959 Make_Procedure_Call_Statement (Loc,
960 Name =>
961 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
962 Parameter_Associations => New_List (
963 New_Occurrence_Of (Cancel_Param, Loc))));
964 end if;
965 end;
966 end if;
968 Append_List_To (Stmts, Additional_Cleanup);
969 return Stmts;
970 end Build_Cleanup_Statements;
972 -----------------------------
973 -- Build_Controlling_Procs --
974 -----------------------------
976 procedure Build_Controlling_Procs (Typ : Entity_Id) is
977 begin
978 if Is_Array_Type (Typ) then
979 Build_Array_Deep_Procs (Typ);
980 else pragma Assert (Is_Record_Type (Typ));
981 Build_Record_Deep_Procs (Typ);
982 end if;
983 end Build_Controlling_Procs;
985 -----------------------------
986 -- Build_Exception_Handler --
987 -----------------------------
989 function Build_Exception_Handler
990 (Data : Finalization_Exception_Data;
991 For_Library : Boolean := False) return Node_Id
993 Actuals : List_Id;
994 Proc_To_Call : Entity_Id;
995 Except : Node_Id;
996 Stmts : List_Id;
998 begin
999 pragma Assert (Present (Data.Raised_Id));
1001 if Exception_Extra_Info
1002 or else (For_Library and not Restricted_Profile)
1003 then
1004 if Exception_Extra_Info then
1006 -- Generate:
1008 -- Get_Current_Excep.all
1010 Except :=
1011 Make_Function_Call (Data.Loc,
1012 Name =>
1013 Make_Explicit_Dereference (Data.Loc,
1014 Prefix =>
1015 New_Occurrence_Of
1016 (RTE (RE_Get_Current_Excep), Data.Loc)));
1018 else
1019 -- Generate:
1021 -- null
1023 Except := Make_Null (Data.Loc);
1024 end if;
1026 if For_Library and then not Restricted_Profile then
1027 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1028 Actuals := New_List (Except);
1030 else
1031 Proc_To_Call := RTE (RE_Save_Occurrence);
1033 -- The dereference occurs only when Exception_Extra_Info is true,
1034 -- and therefore Except is not null.
1036 Actuals :=
1037 New_List (
1038 New_Occurrence_Of (Data.E_Id, Data.Loc),
1039 Make_Explicit_Dereference (Data.Loc, Except));
1040 end if;
1042 -- Generate:
1044 -- when others =>
1045 -- if not Raised_Id then
1046 -- Raised_Id := True;
1048 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1049 -- or
1050 -- Save_Library_Occurrence (Get_Current_Excep.all);
1051 -- end if;
1053 Stmts :=
1054 New_List (
1055 Make_If_Statement (Data.Loc,
1056 Condition =>
1057 Make_Op_Not (Data.Loc,
1058 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1060 Then_Statements => New_List (
1061 Make_Assignment_Statement (Data.Loc,
1062 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1063 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1065 Make_Procedure_Call_Statement (Data.Loc,
1066 Name =>
1067 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1068 Parameter_Associations => Actuals))));
1070 else
1071 -- Generate:
1073 -- Raised_Id := True;
1075 Stmts := New_List (
1076 Make_Assignment_Statement (Data.Loc,
1077 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1078 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1079 end if;
1081 -- Generate:
1083 -- when others =>
1085 return
1086 Make_Exception_Handler (Data.Loc,
1087 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1088 Statements => Stmts);
1089 end Build_Exception_Handler;
1091 -------------------------------
1092 -- Build_Finalization_Master --
1093 -------------------------------
1095 procedure Build_Finalization_Master
1096 (Typ : Entity_Id;
1097 For_Lib_Level : Boolean := False;
1098 For_Private : Boolean := False;
1099 Context_Scope : Entity_Id := Empty;
1100 Insertion_Node : Node_Id := Empty)
1102 procedure Add_Pending_Access_Type
1103 (Typ : Entity_Id;
1104 Ptr_Typ : Entity_Id);
1105 -- Add access type Ptr_Typ to the pending access type list for type Typ
1107 -----------------------------
1108 -- Add_Pending_Access_Type --
1109 -----------------------------
1111 procedure Add_Pending_Access_Type
1112 (Typ : Entity_Id;
1113 Ptr_Typ : Entity_Id)
1115 List : Elist_Id;
1117 begin
1118 if Present (Pending_Access_Types (Typ)) then
1119 List := Pending_Access_Types (Typ);
1120 else
1121 List := New_Elmt_List;
1122 Set_Pending_Access_Types (Typ, List);
1123 end if;
1125 Prepend_Elmt (Ptr_Typ, List);
1126 end Add_Pending_Access_Type;
1128 -- Local variables
1130 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1132 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1133 -- A finalization master created for a named access type is associated
1134 -- with the full view (if applicable) as a consequence of freezing. The
1135 -- full view criteria does not apply to anonymous access types because
1136 -- those cannot have a private and a full view.
1138 -- Start of processing for Build_Finalization_Master
1140 begin
1141 -- Nothing to do if the circumstances do not allow for a finalization
1142 -- master.
1144 if not Allows_Finalization_Master (Typ) then
1145 return;
1147 -- Various machinery such as freezing may have already created a
1148 -- finalization master.
1150 elsif Present (Finalization_Master (Ptr_Typ)) then
1151 return;
1152 end if;
1154 declare
1155 Actions : constant List_Id := New_List;
1156 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1157 Fin_Mas_Id : Entity_Id;
1158 Pool_Id : Entity_Id;
1160 begin
1161 -- Source access types use fixed master names since the master is
1162 -- inserted in the same source unit only once. The only exception to
1163 -- this are instances using the same access type as generic actual.
1165 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1166 Fin_Mas_Id :=
1167 Make_Defining_Identifier (Loc,
1168 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
1170 -- Internally generated access types use temporaries as their names
1171 -- due to possible collision with identical names coming from other
1172 -- packages.
1174 else
1175 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1176 end if;
1178 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1180 -- Generate:
1181 -- <Ptr_Typ>FM : aliased Finalization_Master;
1183 Append_To (Actions,
1184 Make_Object_Declaration (Loc,
1185 Defining_Identifier => Fin_Mas_Id,
1186 Aliased_Present => True,
1187 Object_Definition =>
1188 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
1190 -- Set the associated pool and primitive Finalize_Address of the new
1191 -- finalization master.
1193 -- The access type has a user-defined storage pool, use it
1195 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1196 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1198 -- Otherwise the default choice is the global storage pool
1200 else
1201 Pool_Id := RTE (RE_Global_Pool_Object);
1202 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1203 end if;
1205 -- Generate:
1206 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1208 Append_To (Actions,
1209 Make_Procedure_Call_Statement (Loc,
1210 Name =>
1211 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
1212 Parameter_Associations => New_List (
1213 New_Occurrence_Of (Fin_Mas_Id, Loc),
1214 Make_Attribute_Reference (Loc,
1215 Prefix => New_Occurrence_Of (Pool_Id, Loc),
1216 Attribute_Name => Name_Unrestricted_Access))));
1218 -- Finalize_Address is not generated in CodePeer mode because the
1219 -- body contains address arithmetic. Skip this step.
1221 if CodePeer_Mode then
1222 null;
1224 -- Associate the Finalize_Address primitive of the designated type
1225 -- with the finalization master of the access type. The designated
1226 -- type must be forzen as Finalize_Address is generated when the
1227 -- freeze node is expanded.
1229 elsif Is_Frozen (Desig_Typ)
1230 and then Present (Finalize_Address (Desig_Typ))
1232 -- The finalization master of an anonymous access type may need
1233 -- to be inserted in a specific place in the tree. For instance:
1235 -- type Comp_Typ;
1237 -- <finalization master of "access Comp_Typ">
1239 -- type Rec_Typ is record
1240 -- Comp : access Comp_Typ;
1241 -- end record;
1243 -- <freeze node for Comp_Typ>
1244 -- <freeze node for Rec_Typ>
1246 -- Due to this oddity, the anonymous access type is stored for
1247 -- later processing (see below).
1249 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
1250 then
1251 -- Generate:
1252 -- Set_Finalize_Address
1253 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1255 Append_To (Actions,
1256 Make_Set_Finalize_Address_Call
1257 (Loc => Loc,
1258 Ptr_Typ => Ptr_Typ));
1260 -- Otherwise the designated type is either anonymous access or a
1261 -- Taft-amendment type and has not been frozen. Store the access
1262 -- type for later processing (see Freeze_Type).
1264 else
1265 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1266 end if;
1268 -- A finalization master created for an access designating a type
1269 -- with private components is inserted before a context-dependent
1270 -- node.
1272 if For_Private then
1274 -- At this point both the scope of the context and the insertion
1275 -- mode must be known.
1277 pragma Assert (Present (Context_Scope));
1278 pragma Assert (Present (Insertion_Node));
1280 Push_Scope (Context_Scope);
1282 -- Treat use clauses as declarations and insert directly in front
1283 -- of them.
1285 if Nkind_In (Insertion_Node, N_Use_Package_Clause,
1286 N_Use_Type_Clause)
1287 then
1288 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1289 else
1290 Insert_Actions (Insertion_Node, Actions);
1291 end if;
1293 Pop_Scope;
1295 -- The finalization master belongs to an access result type related
1296 -- to a build-in-place function call used to initialize a library
1297 -- level object. The master must be inserted in front of the access
1298 -- result type declaration denoted by Insertion_Node.
1300 elsif For_Lib_Level then
1301 pragma Assert (Present (Insertion_Node));
1302 Insert_Actions (Insertion_Node, Actions);
1304 -- Otherwise the finalization master and its initialization become a
1305 -- part of the freeze node.
1307 else
1308 Append_Freeze_Actions (Ptr_Typ, Actions);
1309 end if;
1310 end;
1311 end Build_Finalization_Master;
1313 ---------------------
1314 -- Build_Finalizer --
1315 ---------------------
1317 procedure Build_Finalizer
1318 (N : Node_Id;
1319 Clean_Stmts : List_Id;
1320 Mark_Id : Entity_Id;
1321 Top_Decls : List_Id;
1322 Defer_Abort : Boolean;
1323 Fin_Id : out Entity_Id)
1325 Acts_As_Clean : constant Boolean :=
1326 Present (Mark_Id)
1327 or else
1328 (Present (Clean_Stmts)
1329 and then Is_Non_Empty_List (Clean_Stmts));
1330 Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
1331 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1332 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1333 For_Package : constant Boolean :=
1334 For_Package_Body or else For_Package_Spec;
1335 Loc : constant Source_Ptr := Sloc (N);
1337 -- NOTE: Local variable declarations are conservative and do not create
1338 -- structures right from the start. Entities and lists are created once
1339 -- it has been established that N has at least one controlled object.
1341 Components_Built : Boolean := False;
1342 -- A flag used to avoid double initialization of entities and lists. If
1343 -- the flag is set then the following variables have been initialized:
1344 -- Counter_Id
1345 -- Finalizer_Decls
1346 -- Finalizer_Stmts
1347 -- Jump_Alts
1349 Counter_Id : Entity_Id := Empty;
1350 Counter_Val : Nat := 0;
1351 -- Name and value of the state counter
1353 Decls : List_Id := No_List;
1354 -- Declarative region of N (if available). If N is a package declaration
1355 -- Decls denotes the visible declarations.
1357 Finalizer_Data : Finalization_Exception_Data;
1358 -- Data for the exception
1360 Finalizer_Decls : List_Id := No_List;
1361 -- Local variable declarations. This list holds the label declarations
1362 -- of all jump block alternatives as well as the declaration of the
1363 -- local exception occurrence and the raised flag:
1364 -- E : Exception_Occurrence;
1365 -- Raised : Boolean := False;
1366 -- L<counter value> : label;
1368 Finalizer_Insert_Nod : Node_Id := Empty;
1369 -- Insertion point for the finalizer body. Depending on the context
1370 -- (Nkind of N) and the individual grouping of controlled objects, this
1371 -- node may denote a package declaration or body, package instantiation,
1372 -- block statement or a counter update statement.
1374 Finalizer_Stmts : List_Id := No_List;
1375 -- The statement list of the finalizer body. It contains the following:
1377 -- Abort_Defer; -- Added if abort is allowed
1378 -- <call to Prev_At_End> -- Added if exists
1379 -- <cleanup statements> -- Added if Acts_As_Clean
1380 -- <jump block> -- Added if Has_Ctrl_Objs
1381 -- <finalization statements> -- Added if Has_Ctrl_Objs
1382 -- <stack release> -- Added if Mark_Id exists
1383 -- Abort_Undefer; -- Added if abort is allowed
1385 Has_Ctrl_Objs : Boolean := False;
1386 -- A general flag which denotes whether N has at least one controlled
1387 -- object.
1389 Has_Tagged_Types : Boolean := False;
1390 -- A general flag which indicates whether N has at least one library-
1391 -- level tagged type declaration.
1393 HSS : Node_Id := Empty;
1394 -- The sequence of statements of N (if available)
1396 Jump_Alts : List_Id := No_List;
1397 -- Jump block alternatives. Depending on the value of the state counter,
1398 -- the control flow jumps to a sequence of finalization statements. This
1399 -- list contains the following:
1401 -- when <counter value> =>
1402 -- goto L<counter value>;
1404 Jump_Block_Insert_Nod : Node_Id := Empty;
1405 -- Specific point in the finalizer statements where the jump block is
1406 -- inserted.
1408 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1409 -- The last controlled construct encountered when processing the top
1410 -- level lists of N. This can be a nested package, an instantiation or
1411 -- an object declaration.
1413 Prev_At_End : Entity_Id := Empty;
1414 -- The previous at end procedure of the handled statements block of N
1416 Priv_Decls : List_Id := No_List;
1417 -- The private declarations of N if N is a package declaration
1419 Spec_Id : Entity_Id := Empty;
1420 Spec_Decls : List_Id := Top_Decls;
1421 Stmts : List_Id := No_List;
1423 Tagged_Type_Stmts : List_Id := No_List;
1424 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1425 -- tagged types found in N.
1427 -----------------------
1428 -- Local subprograms --
1429 -----------------------
1431 procedure Build_Components;
1432 -- Create all entites and initialize all lists used in the creation of
1433 -- the finalizer.
1435 procedure Create_Finalizer;
1436 -- Create the spec and body of the finalizer and insert them in the
1437 -- proper place in the tree depending on the context.
1439 procedure Process_Declarations
1440 (Decls : List_Id;
1441 Preprocess : Boolean := False;
1442 Top_Level : Boolean := False);
1443 -- Inspect a list of declarations or statements which may contain
1444 -- objects that need finalization. When flag Preprocess is set, the
1445 -- routine will simply count the total number of controlled objects in
1446 -- Decls. Flag Top_Level denotes whether the processing is done for
1447 -- objects in nested package declarations or instances.
1449 procedure Process_Object_Declaration
1450 (Decl : Node_Id;
1451 Has_No_Init : Boolean := False;
1452 Is_Protected : Boolean := False);
1453 -- Generate all the machinery associated with the finalization of a
1454 -- single object. Flag Has_No_Init is used to denote certain contexts
1455 -- where Decl does not have initialization call(s). Flag Is_Protected
1456 -- is set when Decl denotes a simple protected object.
1458 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1459 -- Generate all the code necessary to unregister the external tag of a
1460 -- tagged type.
1462 ----------------------
1463 -- Build_Components --
1464 ----------------------
1466 procedure Build_Components is
1467 Counter_Decl : Node_Id;
1468 Counter_Typ : Entity_Id;
1469 Counter_Typ_Decl : Node_Id;
1471 begin
1472 pragma Assert (Present (Decls));
1474 -- This routine might be invoked several times when dealing with
1475 -- constructs that have two lists (either two declarative regions
1476 -- or declarations and statements). Avoid double initialization.
1478 if Components_Built then
1479 return;
1480 end if;
1482 Components_Built := True;
1484 if Has_Ctrl_Objs then
1486 -- Create entities for the counter, its type, the local exception
1487 -- and the raised flag.
1489 Counter_Id := Make_Temporary (Loc, 'C');
1490 Counter_Typ := Make_Temporary (Loc, 'T');
1492 Finalizer_Decls := New_List;
1494 Build_Object_Declarations
1495 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1497 -- Since the total number of controlled objects is always known,
1498 -- build a subtype of Natural with precise bounds. This allows
1499 -- the backend to optimize the case statement. Generate:
1501 -- subtype Tnn is Natural range 0 .. Counter_Val;
1503 Counter_Typ_Decl :=
1504 Make_Subtype_Declaration (Loc,
1505 Defining_Identifier => Counter_Typ,
1506 Subtype_Indication =>
1507 Make_Subtype_Indication (Loc,
1508 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1509 Constraint =>
1510 Make_Range_Constraint (Loc,
1511 Range_Expression =>
1512 Make_Range (Loc,
1513 Low_Bound =>
1514 Make_Integer_Literal (Loc, Uint_0),
1515 High_Bound =>
1516 Make_Integer_Literal (Loc, Counter_Val)))));
1518 -- Generate the declaration of the counter itself:
1520 -- Counter : Integer := 0;
1522 Counter_Decl :=
1523 Make_Object_Declaration (Loc,
1524 Defining_Identifier => Counter_Id,
1525 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1526 Expression => Make_Integer_Literal (Loc, 0));
1528 -- Set the type of the counter explicitly to prevent errors when
1529 -- examining object declarations later on.
1531 Set_Etype (Counter_Id, Counter_Typ);
1533 -- The counter and its type are inserted before the source
1534 -- declarations of N.
1536 Prepend_To (Decls, Counter_Decl);
1537 Prepend_To (Decls, Counter_Typ_Decl);
1539 -- The counter and its associated type must be manually analyzed
1540 -- since N has already been analyzed. Use the scope of the spec
1541 -- when inserting in a package.
1543 if For_Package then
1544 Push_Scope (Spec_Id);
1545 Analyze (Counter_Typ_Decl);
1546 Analyze (Counter_Decl);
1547 Pop_Scope;
1549 else
1550 Analyze (Counter_Typ_Decl);
1551 Analyze (Counter_Decl);
1552 end if;
1554 Jump_Alts := New_List;
1555 end if;
1557 -- If the context requires additional cleanup, the finalization
1558 -- machinery is added after the cleanup code.
1560 if Acts_As_Clean then
1561 Finalizer_Stmts := Clean_Stmts;
1562 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1563 else
1564 Finalizer_Stmts := New_List;
1565 end if;
1567 if Has_Tagged_Types then
1568 Tagged_Type_Stmts := New_List;
1569 end if;
1570 end Build_Components;
1572 ----------------------
1573 -- Create_Finalizer --
1574 ----------------------
1576 procedure Create_Finalizer is
1577 function New_Finalizer_Name return Name_Id;
1578 -- Create a fully qualified name of a package spec or body finalizer.
1579 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1581 ------------------------
1582 -- New_Finalizer_Name --
1583 ------------------------
1585 function New_Finalizer_Name return Name_Id is
1586 procedure New_Finalizer_Name (Id : Entity_Id);
1587 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1588 -- has a non-standard scope, process the scope first.
1590 ------------------------
1591 -- New_Finalizer_Name --
1592 ------------------------
1594 procedure New_Finalizer_Name (Id : Entity_Id) is
1595 begin
1596 if Scope (Id) = Standard_Standard then
1597 Get_Name_String (Chars (Id));
1599 else
1600 New_Finalizer_Name (Scope (Id));
1601 Add_Str_To_Name_Buffer ("__");
1602 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1603 end if;
1604 end New_Finalizer_Name;
1606 -- Start of processing for New_Finalizer_Name
1608 begin
1609 -- Create the fully qualified name of the enclosing scope
1611 New_Finalizer_Name (Spec_Id);
1613 -- Generate:
1614 -- __finalize_[spec|body]
1616 Add_Str_To_Name_Buffer ("__finalize_");
1618 if For_Package_Spec then
1619 Add_Str_To_Name_Buffer ("spec");
1620 else
1621 Add_Str_To_Name_Buffer ("body");
1622 end if;
1624 return Name_Find;
1625 end New_Finalizer_Name;
1627 -- Local variables
1629 Body_Id : Entity_Id;
1630 Fin_Body : Node_Id;
1631 Fin_Spec : Node_Id;
1632 Jump_Block : Node_Id;
1633 Label : Node_Id;
1634 Label_Id : Entity_Id;
1636 -- Start of processing for Create_Finalizer
1638 begin
1639 -- Step 1: Creation of the finalizer name
1641 -- Packages must use a distinct name for their finalizers since the
1642 -- binder will have to generate calls to them by name. The name is
1643 -- of the following form:
1645 -- xx__yy__finalize_[spec|body]
1647 if For_Package then
1648 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1649 Set_Has_Qualified_Name (Fin_Id);
1650 Set_Has_Fully_Qualified_Name (Fin_Id);
1652 -- The default name is _finalizer
1654 else
1655 Fin_Id :=
1656 Make_Defining_Identifier (Loc,
1657 Chars => New_External_Name (Name_uFinalizer));
1659 -- The visibility semantics of AT_END handlers force a strange
1660 -- separation of spec and body for stack-related finalizers:
1662 -- declare : Enclosing_Scope
1663 -- procedure _finalizer;
1664 -- begin
1665 -- <controlled objects>
1666 -- procedure _finalizer is
1667 -- ...
1668 -- at end
1669 -- _finalizer;
1670 -- end;
1672 -- Both spec and body are within the same construct and scope, but
1673 -- the body is part of the handled sequence of statements. This
1674 -- placement confuses the elaboration mechanism on targets where
1675 -- AT_END handlers are expanded into "when all others" handlers:
1677 -- exception
1678 -- when all others =>
1679 -- _finalizer; -- appears to require elab checks
1680 -- at end
1681 -- _finalizer;
1682 -- end;
1684 -- Since the compiler guarantees that the body of a _finalizer is
1685 -- always inserted in the same construct where the AT_END handler
1686 -- resides, there is no need for elaboration checks.
1688 Set_Kill_Elaboration_Checks (Fin_Id);
1690 -- Inlining the finalizer produces a substantial speedup at -O2.
1691 -- It is inlined by default at -O3. Either way, it is called
1692 -- exactly twice (once on the normal path, and once for
1693 -- exceptions/abort), so this won't bloat the code too much.
1695 Set_Is_Inlined (Fin_Id);
1696 end if;
1698 -- Step 2: Creation of the finalizer specification
1700 -- Generate:
1701 -- procedure Fin_Id;
1703 Fin_Spec :=
1704 Make_Subprogram_Declaration (Loc,
1705 Specification =>
1706 Make_Procedure_Specification (Loc,
1707 Defining_Unit_Name => Fin_Id));
1709 -- Step 3: Creation of the finalizer body
1711 if Has_Ctrl_Objs then
1713 -- Add L0, the default destination to the jump block
1715 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1716 Set_Entity (Label_Id,
1717 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1718 Label := Make_Label (Loc, Label_Id);
1720 -- Generate:
1721 -- L0 : label;
1723 Prepend_To (Finalizer_Decls,
1724 Make_Implicit_Label_Declaration (Loc,
1725 Defining_Identifier => Entity (Label_Id),
1726 Label_Construct => Label));
1728 -- Generate:
1729 -- when others =>
1730 -- goto L0;
1732 Append_To (Jump_Alts,
1733 Make_Case_Statement_Alternative (Loc,
1734 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1735 Statements => New_List (
1736 Make_Goto_Statement (Loc,
1737 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1739 -- Generate:
1740 -- <<L0>>
1742 Append_To (Finalizer_Stmts, Label);
1744 -- Create the jump block which controls the finalization flow
1745 -- depending on the value of the state counter.
1747 Jump_Block :=
1748 Make_Case_Statement (Loc,
1749 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1750 Alternatives => Jump_Alts);
1752 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1753 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1754 else
1755 Prepend_To (Finalizer_Stmts, Jump_Block);
1756 end if;
1757 end if;
1759 -- Add the library-level tagged type unregistration machinery before
1760 -- the jump block circuitry. This ensures that external tags will be
1761 -- removed even if a finalization exception occurs at some point.
1763 if Has_Tagged_Types then
1764 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1765 end if;
1767 -- Add a call to the previous At_End handler if it exists. The call
1768 -- must always precede the jump block.
1770 if Present (Prev_At_End) then
1771 Prepend_To (Finalizer_Stmts,
1772 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1774 -- Clear the At_End handler since we have already generated the
1775 -- proper replacement call for it.
1777 Set_At_End_Proc (HSS, Empty);
1778 end if;
1780 -- Release the secondary stack mark
1782 if Present (Mark_Id) then
1783 Append_To (Finalizer_Stmts, Build_SS_Release_Call (Loc, Mark_Id));
1784 end if;
1786 -- Protect the statements with abort defer/undefer. This is only when
1787 -- aborts are allowed and the cleanup statements require deferral or
1788 -- there are controlled objects to be finalized. Note that the abort
1789 -- defer/undefer pair does not require an extra block because each
1790 -- finalization exception is caught in its corresponding finalization
1791 -- block. As a result, the call to Abort_Defer always takes place.
1793 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1794 Prepend_To (Finalizer_Stmts,
1795 Build_Runtime_Call (Loc, RE_Abort_Defer));
1797 Append_To (Finalizer_Stmts,
1798 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1799 end if;
1801 -- The local exception does not need to be reraised for library-level
1802 -- finalizers. Note that this action must be carried out after object
1803 -- cleanup, secondary stack release, and abort undeferral. Generate:
1805 -- if Raised and then not Abort then
1806 -- Raise_From_Controlled_Operation (E);
1807 -- end if;
1809 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1810 Append_To (Finalizer_Stmts,
1811 Build_Raise_Statement (Finalizer_Data));
1812 end if;
1814 -- Generate:
1815 -- procedure Fin_Id is
1816 -- Abort : constant Boolean := Triggered_By_Abort;
1817 -- <or>
1818 -- Abort : constant Boolean := False; -- no abort
1820 -- E : Exception_Occurrence; -- All added if flag
1821 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1822 -- L0 : label;
1823 -- ...
1824 -- Lnn : label;
1826 -- begin
1827 -- Abort_Defer; -- Added if abort is allowed
1828 -- <call to Prev_At_End> -- Added if exists
1829 -- <cleanup statements> -- Added if Acts_As_Clean
1830 -- <jump block> -- Added if Has_Ctrl_Objs
1831 -- <finalization statements> -- Added if Has_Ctrl_Objs
1832 -- <stack release> -- Added if Mark_Id exists
1833 -- Abort_Undefer; -- Added if abort is allowed
1834 -- <exception propagation> -- Added if Has_Ctrl_Objs
1835 -- end Fin_Id;
1837 -- Create the body of the finalizer
1839 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1841 if For_Package then
1842 Set_Has_Qualified_Name (Body_Id);
1843 Set_Has_Fully_Qualified_Name (Body_Id);
1844 end if;
1846 Fin_Body :=
1847 Make_Subprogram_Body (Loc,
1848 Specification =>
1849 Make_Procedure_Specification (Loc,
1850 Defining_Unit_Name => Body_Id),
1851 Declarations => Finalizer_Decls,
1852 Handled_Statement_Sequence =>
1853 Make_Handled_Sequence_Of_Statements (Loc,
1854 Statements => Finalizer_Stmts));
1856 -- Step 4: Spec and body insertion, analysis
1858 if For_Package then
1860 -- If the package spec has private declarations, the finalizer
1861 -- body must be added to the end of the list in order to have
1862 -- visibility of all private controlled objects.
1864 if For_Package_Spec then
1865 if Present (Priv_Decls) then
1866 Append_To (Priv_Decls, Fin_Spec);
1867 Append_To (Priv_Decls, Fin_Body);
1868 else
1869 Append_To (Decls, Fin_Spec);
1870 Append_To (Decls, Fin_Body);
1871 end if;
1873 -- For package bodies, both the finalizer spec and body are
1874 -- inserted at the end of the package declarations.
1876 else
1877 Append_To (Decls, Fin_Spec);
1878 Append_To (Decls, Fin_Body);
1879 end if;
1881 -- Push the name of the package
1883 Push_Scope (Spec_Id);
1884 Analyze (Fin_Spec);
1885 Analyze (Fin_Body);
1886 Pop_Scope;
1888 -- Non-package case
1890 else
1891 -- Create the spec for the finalizer. The At_End handler must be
1892 -- able to call the body which resides in a nested structure.
1894 -- Generate:
1895 -- declare
1896 -- procedure Fin_Id; -- Spec
1897 -- begin
1898 -- <objects and possibly statements>
1899 -- procedure Fin_Id is ... -- Body
1900 -- <statements>
1901 -- at end
1902 -- Fin_Id; -- At_End handler
1903 -- end;
1905 pragma Assert (Present (Spec_Decls));
1907 Append_To (Spec_Decls, Fin_Spec);
1908 Analyze (Fin_Spec);
1910 -- When the finalizer acts solely as a cleanup routine, the body
1911 -- is inserted right after the spec.
1913 if Acts_As_Clean and not Has_Ctrl_Objs then
1914 Insert_After (Fin_Spec, Fin_Body);
1916 -- In all other cases the body is inserted after either:
1918 -- 1) The counter update statement of the last controlled object
1919 -- 2) The last top level nested controlled package
1920 -- 3) The last top level controlled instantiation
1922 else
1923 -- Manually freeze the spec. This is somewhat of a hack because
1924 -- a subprogram is frozen when its body is seen and the freeze
1925 -- node appears right before the body. However, in this case,
1926 -- the spec must be frozen earlier since the At_End handler
1927 -- must be able to call it.
1929 -- declare
1930 -- procedure Fin_Id; -- Spec
1931 -- [Fin_Id] -- Freeze node
1932 -- begin
1933 -- ...
1934 -- at end
1935 -- Fin_Id; -- At_End handler
1936 -- end;
1938 Ensure_Freeze_Node (Fin_Id);
1939 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1940 Set_Is_Frozen (Fin_Id);
1942 -- In the case where the last construct to contain a controlled
1943 -- object is either a nested package, an instantiation or a
1944 -- freeze node, the body must be inserted directly after the
1945 -- construct.
1947 if Nkind_In (Last_Top_Level_Ctrl_Construct,
1948 N_Freeze_Entity,
1949 N_Package_Declaration,
1950 N_Package_Body)
1951 then
1952 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1953 end if;
1955 Insert_After (Finalizer_Insert_Nod, Fin_Body);
1956 end if;
1958 Analyze (Fin_Body, Suppress => All_Checks);
1959 end if;
1960 end Create_Finalizer;
1962 --------------------------
1963 -- Process_Declarations --
1964 --------------------------
1966 procedure Process_Declarations
1967 (Decls : List_Id;
1968 Preprocess : Boolean := False;
1969 Top_Level : Boolean := False)
1971 Decl : Node_Id;
1972 Expr : Node_Id;
1973 Obj_Id : Entity_Id;
1974 Obj_Typ : Entity_Id;
1975 Pack_Id : Entity_Id;
1976 Spec : Node_Id;
1977 Typ : Entity_Id;
1979 Old_Counter_Val : Nat;
1980 -- This variable is used to determine whether a nested package or
1981 -- instance contains at least one controlled object.
1983 procedure Processing_Actions
1984 (Has_No_Init : Boolean := False;
1985 Is_Protected : Boolean := False);
1986 -- Depending on the mode of operation of Process_Declarations, either
1987 -- increment the controlled object counter, set the controlled object
1988 -- flag and store the last top level construct or process the current
1989 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1990 -- the current declaration may not have initialization proc(s). Flag
1991 -- Is_Protected should be set when the current declaration denotes a
1992 -- simple protected object.
1994 ------------------------
1995 -- Processing_Actions --
1996 ------------------------
1998 procedure Processing_Actions
1999 (Has_No_Init : Boolean := False;
2000 Is_Protected : Boolean := False)
2002 begin
2003 -- Library-level tagged type
2005 if Nkind (Decl) = N_Full_Type_Declaration then
2006 if Preprocess then
2007 Has_Tagged_Types := True;
2009 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2010 Last_Top_Level_Ctrl_Construct := Decl;
2011 end if;
2013 else
2014 Process_Tagged_Type_Declaration (Decl);
2015 end if;
2017 -- Controlled object declaration
2019 else
2020 if Preprocess then
2021 Counter_Val := Counter_Val + 1;
2022 Has_Ctrl_Objs := True;
2024 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2025 Last_Top_Level_Ctrl_Construct := Decl;
2026 end if;
2028 else
2029 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2030 end if;
2031 end if;
2032 end Processing_Actions;
2034 -- Start of processing for Process_Declarations
2036 begin
2037 if No (Decls) or else Is_Empty_List (Decls) then
2038 return;
2039 end if;
2041 -- Process all declarations in reverse order
2043 Decl := Last_Non_Pragma (Decls);
2044 while Present (Decl) loop
2046 -- Library-level tagged types
2048 if Nkind (Decl) = N_Full_Type_Declaration then
2049 Typ := Defining_Identifier (Decl);
2051 -- Ignored Ghost types do not need any cleanup actions because
2052 -- they will not appear in the final tree.
2054 if Is_Ignored_Ghost_Entity (Typ) then
2055 null;
2057 elsif Is_Tagged_Type (Typ)
2058 and then Is_Library_Level_Entity (Typ)
2059 and then Convention (Typ) = Convention_Ada
2060 and then Present (Access_Disp_Table (Typ))
2061 and then RTE_Available (RE_Register_Tag)
2062 and then not Is_Abstract_Type (Typ)
2063 and then not No_Run_Time_Mode
2064 then
2065 Processing_Actions;
2066 end if;
2068 -- Regular object declarations
2070 elsif Nkind (Decl) = N_Object_Declaration then
2071 Obj_Id := Defining_Identifier (Decl);
2072 Obj_Typ := Base_Type (Etype (Obj_Id));
2073 Expr := Expression (Decl);
2075 -- Bypass any form of processing for objects which have their
2076 -- finalization disabled. This applies only to objects at the
2077 -- library level.
2079 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2080 null;
2082 -- Finalization of transient objects are treated separately in
2083 -- order to handle sensitive cases. These include:
2085 -- * Aggregate expansion
2086 -- * If, case, and expression with actions expansion
2087 -- * Transient scopes
2089 -- If one of those contexts has marked the transient object as
2090 -- ignored, do not generate finalization actions for it.
2092 elsif Is_Finalized_Transient (Obj_Id)
2093 or else Is_Ignored_Transient (Obj_Id)
2094 then
2095 null;
2097 -- Ignored Ghost objects do not need any cleanup actions
2098 -- because they will not appear in the final tree.
2100 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2101 null;
2103 -- The object is of the form:
2104 -- Obj : [constant] Typ [:= Expr];
2106 -- Do not process tag-to-class-wide conversions because they do
2107 -- not yield an object. Do not process the incomplete view of a
2108 -- deferred constant. Note that an object initialized by means
2109 -- of a build-in-place function call may appear as a deferred
2110 -- constant after expansion activities. These kinds of objects
2111 -- must be finalized.
2113 elsif not Is_Imported (Obj_Id)
2114 and then Needs_Finalization (Obj_Typ)
2115 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
2116 and then not (Ekind (Obj_Id) = E_Constant
2117 and then not Has_Completion (Obj_Id)
2118 and then No (BIP_Initialization_Call (Obj_Id)))
2119 then
2120 Processing_Actions;
2122 -- The object is of the form:
2123 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2125 -- Obj : Access_Typ :=
2126 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2128 elsif Is_Access_Type (Obj_Typ)
2129 and then Needs_Finalization
2130 (Available_View (Designated_Type (Obj_Typ)))
2131 and then Present (Expr)
2132 and then
2133 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2134 or else
2135 (Is_Non_BIP_Func_Call (Expr)
2136 and then not Is_Related_To_Func_Return (Obj_Id)))
2137 then
2138 Processing_Actions (Has_No_Init => True);
2140 -- Processing for "hook" objects generated for transient
2141 -- objects declared inside an Expression_With_Actions.
2143 elsif Is_Access_Type (Obj_Typ)
2144 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2145 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2146 N_Object_Declaration
2147 then
2148 Processing_Actions (Has_No_Init => True);
2150 -- Process intermediate results of an if expression with one
2151 -- of the alternatives using a controlled function call.
2153 elsif Is_Access_Type (Obj_Typ)
2154 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2155 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2156 N_Defining_Identifier
2157 and then Present (Expr)
2158 and then Nkind (Expr) = N_Null
2159 then
2160 Processing_Actions (Has_No_Init => True);
2162 -- Simple protected objects which use type System.Tasking.
2163 -- Protected_Objects.Protection to manage their locks should
2164 -- be treated as controlled since they require manual cleanup.
2165 -- The only exception is illustrated in the following example:
2167 -- package Pkg is
2168 -- type Ctrl is new Controlled ...
2169 -- procedure Finalize (Obj : in out Ctrl);
2170 -- Lib_Obj : Ctrl;
2171 -- end Pkg;
2173 -- package body Pkg is
2174 -- protected Prot is
2175 -- procedure Do_Something (Obj : in out Ctrl);
2176 -- end Prot;
2178 -- protected body Prot is
2179 -- procedure Do_Something (Obj : in out Ctrl) is ...
2180 -- end Prot;
2182 -- procedure Finalize (Obj : in out Ctrl) is
2183 -- begin
2184 -- Prot.Do_Something (Obj);
2185 -- end Finalize;
2186 -- end Pkg;
2188 -- Since for the most part entities in package bodies depend on
2189 -- those in package specs, Prot's lock should be cleaned up
2190 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2191 -- This act however attempts to invoke Do_Something and fails
2192 -- because the lock has disappeared.
2194 elsif Ekind (Obj_Id) = E_Variable
2195 and then not In_Library_Level_Package_Body (Obj_Id)
2196 and then (Is_Simple_Protected_Type (Obj_Typ)
2197 or else Has_Simple_Protected_Object (Obj_Typ))
2198 then
2199 Processing_Actions (Is_Protected => True);
2200 end if;
2202 -- Specific cases of object renamings
2204 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2205 Obj_Id := Defining_Identifier (Decl);
2206 Obj_Typ := Base_Type (Etype (Obj_Id));
2208 -- Bypass any form of processing for objects which have their
2209 -- finalization disabled. This applies only to objects at the
2210 -- library level.
2212 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2213 null;
2215 -- Ignored Ghost object renamings do not need any cleanup
2216 -- actions because they will not appear in the final tree.
2218 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2219 null;
2221 -- Return object of a build-in-place function. This case is
2222 -- recognized and marked by the expansion of an extended return
2223 -- statement (see Expand_N_Extended_Return_Statement).
2225 elsif Needs_Finalization (Obj_Typ)
2226 and then Is_Return_Object (Obj_Id)
2227 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2228 then
2229 Processing_Actions (Has_No_Init => True);
2231 -- Detect a case where a source object has been initialized by
2232 -- a controlled function call or another object which was later
2233 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2235 -- Obj1 : CW_Type := Src_Obj;
2236 -- Obj2 : CW_Type := Function_Call (...);
2238 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2239 -- Tmp : ... := Function_Call (...)'reference;
2240 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2242 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
2243 Processing_Actions (Has_No_Init => True);
2244 end if;
2246 -- Inspect the freeze node of an access-to-controlled type and
2247 -- look for a delayed finalization master. This case arises when
2248 -- the freeze actions are inserted at a later time than the
2249 -- expansion of the context. Since Build_Finalizer is never called
2250 -- on a single construct twice, the master will be ultimately
2251 -- left out and never finalized. This is also needed for freeze
2252 -- actions of designated types themselves, since in some cases the
2253 -- finalization master is associated with a designated type's
2254 -- freeze node rather than that of the access type (see handling
2255 -- for freeze actions in Build_Finalization_Master).
2257 elsif Nkind (Decl) = N_Freeze_Entity
2258 and then Present (Actions (Decl))
2259 then
2260 Typ := Entity (Decl);
2262 -- Freeze nodes for ignored Ghost types do not need cleanup
2263 -- actions because they will never appear in the final tree.
2265 if Is_Ignored_Ghost_Entity (Typ) then
2266 null;
2268 elsif (Is_Access_Type (Typ)
2269 and then not Is_Access_Subprogram_Type (Typ)
2270 and then Needs_Finalization
2271 (Available_View (Designated_Type (Typ))))
2272 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2273 then
2274 Old_Counter_Val := Counter_Val;
2276 -- Freeze nodes are considered to be identical to packages
2277 -- and blocks in terms of nesting. The difference is that
2278 -- a finalization master created inside the freeze node is
2279 -- at the same nesting level as the node itself.
2281 Process_Declarations (Actions (Decl), Preprocess);
2283 -- The freeze node contains a finalization master
2285 if Preprocess
2286 and then Top_Level
2287 and then No (Last_Top_Level_Ctrl_Construct)
2288 and then Counter_Val > Old_Counter_Val
2289 then
2290 Last_Top_Level_Ctrl_Construct := Decl;
2291 end if;
2292 end if;
2294 -- Nested package declarations, avoid generics
2296 elsif Nkind (Decl) = N_Package_Declaration then
2297 Pack_Id := Defining_Entity (Decl);
2298 Spec := Specification (Decl);
2300 -- Do not inspect an ignored Ghost package because all code
2301 -- found within will not appear in the final tree.
2303 if Is_Ignored_Ghost_Entity (Pack_Id) then
2304 null;
2306 elsif Ekind (Pack_Id) /= E_Generic_Package then
2307 Old_Counter_Val := Counter_Val;
2308 Process_Declarations
2309 (Private_Declarations (Spec), Preprocess);
2310 Process_Declarations
2311 (Visible_Declarations (Spec), Preprocess);
2313 -- Either the visible or the private declarations contain a
2314 -- controlled object. The nested package declaration is the
2315 -- last such construct.
2317 if Preprocess
2318 and then Top_Level
2319 and then No (Last_Top_Level_Ctrl_Construct)
2320 and then Counter_Val > Old_Counter_Val
2321 then
2322 Last_Top_Level_Ctrl_Construct := Decl;
2323 end if;
2324 end if;
2326 -- Nested package bodies, avoid generics
2328 elsif Nkind (Decl) = N_Package_Body then
2330 -- Do not inspect an ignored Ghost package body because all
2331 -- code found within will not appear in the final tree.
2333 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2334 null;
2336 elsif Ekind (Corresponding_Spec (Decl)) /=
2337 E_Generic_Package
2338 then
2339 Old_Counter_Val := Counter_Val;
2340 Process_Declarations (Declarations (Decl), Preprocess);
2342 -- The nested package body is the last construct to contain
2343 -- a controlled object.
2345 if Preprocess
2346 and then Top_Level
2347 and then No (Last_Top_Level_Ctrl_Construct)
2348 and then Counter_Val > Old_Counter_Val
2349 then
2350 Last_Top_Level_Ctrl_Construct := Decl;
2351 end if;
2352 end if;
2354 -- Handle a rare case caused by a controlled transient object
2355 -- created as part of a record init proc. The variable is wrapped
2356 -- in a block, but the block is not associated with a transient
2357 -- scope.
2359 elsif Nkind (Decl) = N_Block_Statement
2360 and then Inside_Init_Proc
2361 then
2362 Old_Counter_Val := Counter_Val;
2364 if Present (Handled_Statement_Sequence (Decl)) then
2365 Process_Declarations
2366 (Statements (Handled_Statement_Sequence (Decl)),
2367 Preprocess);
2368 end if;
2370 Process_Declarations (Declarations (Decl), Preprocess);
2372 -- Either the declaration or statement list of the block has a
2373 -- controlled object.
2375 if Preprocess
2376 and then Top_Level
2377 and then No (Last_Top_Level_Ctrl_Construct)
2378 and then Counter_Val > Old_Counter_Val
2379 then
2380 Last_Top_Level_Ctrl_Construct := Decl;
2381 end if;
2383 -- Handle the case where the original context has been wrapped in
2384 -- a block to avoid interference between exception handlers and
2385 -- At_End handlers. Treat the block as transparent and process its
2386 -- contents.
2388 elsif Nkind (Decl) = N_Block_Statement
2389 and then Is_Finalization_Wrapper (Decl)
2390 then
2391 if Present (Handled_Statement_Sequence (Decl)) then
2392 Process_Declarations
2393 (Statements (Handled_Statement_Sequence (Decl)),
2394 Preprocess);
2395 end if;
2397 Process_Declarations (Declarations (Decl), Preprocess);
2398 end if;
2400 Prev_Non_Pragma (Decl);
2401 end loop;
2402 end Process_Declarations;
2404 --------------------------------
2405 -- Process_Object_Declaration --
2406 --------------------------------
2408 procedure Process_Object_Declaration
2409 (Decl : Node_Id;
2410 Has_No_Init : Boolean := False;
2411 Is_Protected : Boolean := False)
2413 Loc : constant Source_Ptr := Sloc (Decl);
2414 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2416 Init_Typ : Entity_Id;
2417 -- The initialization type of the related object declaration. Note
2418 -- that this is not necessarily the same type as Obj_Typ because of
2419 -- possible type derivations.
2421 Obj_Typ : Entity_Id;
2422 -- The type of the related object declaration
2424 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2425 -- Func_Id denotes a build-in-place function. Generate the following
2426 -- cleanup code:
2428 -- if BIPallocfrom > Secondary_Stack'Pos
2429 -- and then BIPfinalizationmaster /= null
2430 -- then
2431 -- declare
2432 -- type Ptr_Typ is access Obj_Typ;
2433 -- for Ptr_Typ'Storage_Pool
2434 -- use Base_Pool (BIPfinalizationmaster);
2435 -- begin
2436 -- Free (Ptr_Typ (Temp));
2437 -- end;
2438 -- end if;
2440 -- Obj_Typ is the type of the current object, Temp is the original
2441 -- allocation which Obj_Id renames.
2443 procedure Find_Last_Init
2444 (Last_Init : out Node_Id;
2445 Body_Insert : out Node_Id);
2446 -- Find the last initialization call related to object declaration
2447 -- Decl. Last_Init denotes the last initialization call which follows
2448 -- Decl. Body_Insert denotes a node where the finalizer body could be
2449 -- potentially inserted after (if blocks are involved).
2451 -----------------------------
2452 -- Build_BIP_Cleanup_Stmts --
2453 -----------------------------
2455 function Build_BIP_Cleanup_Stmts
2456 (Func_Id : Entity_Id) return Node_Id
2458 Decls : constant List_Id := New_List;
2459 Fin_Mas_Id : constant Entity_Id :=
2460 Build_In_Place_Formal
2461 (Func_Id, BIP_Finalization_Master);
2462 Func_Typ : constant Entity_Id := Etype (Func_Id);
2463 Temp_Id : constant Entity_Id :=
2464 Entity (Prefix (Name (Parent (Obj_Id))));
2466 Cond : Node_Id;
2467 Free_Blk : Node_Id;
2468 Free_Stmt : Node_Id;
2469 Pool_Id : Entity_Id;
2470 Ptr_Typ : Entity_Id;
2472 begin
2473 -- Generate:
2474 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2476 Pool_Id := Make_Temporary (Loc, 'P');
2478 Append_To (Decls,
2479 Make_Object_Renaming_Declaration (Loc,
2480 Defining_Identifier => Pool_Id,
2481 Subtype_Mark =>
2482 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2483 Name =>
2484 Make_Explicit_Dereference (Loc,
2485 Prefix =>
2486 Make_Function_Call (Loc,
2487 Name =>
2488 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2489 Parameter_Associations => New_List (
2490 Make_Explicit_Dereference (Loc,
2491 Prefix =>
2492 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2494 -- Create an access type which uses the storage pool of the
2495 -- caller's finalization master.
2497 -- Generate:
2498 -- type Ptr_Typ is access Func_Typ;
2500 Ptr_Typ := Make_Temporary (Loc, 'P');
2502 Append_To (Decls,
2503 Make_Full_Type_Declaration (Loc,
2504 Defining_Identifier => Ptr_Typ,
2505 Type_Definition =>
2506 Make_Access_To_Object_Definition (Loc,
2507 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2509 -- Perform minor decoration in order to set the master and the
2510 -- storage pool attributes.
2512 Set_Ekind (Ptr_Typ, E_Access_Type);
2513 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2514 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2516 -- Create an explicit free statement. Note that the free uses the
2517 -- caller's pool expressed as a renaming.
2519 Free_Stmt :=
2520 Make_Free_Statement (Loc,
2521 Expression =>
2522 Unchecked_Convert_To (Ptr_Typ,
2523 New_Occurrence_Of (Temp_Id, Loc)));
2525 Set_Storage_Pool (Free_Stmt, Pool_Id);
2527 -- Create a block to house the dummy type and the instantiation as
2528 -- well as to perform the cleanup the temporary.
2530 -- Generate:
2531 -- declare
2532 -- <Decls>
2533 -- begin
2534 -- Free (Ptr_Typ (Temp_Id));
2535 -- end;
2537 Free_Blk :=
2538 Make_Block_Statement (Loc,
2539 Declarations => Decls,
2540 Handled_Statement_Sequence =>
2541 Make_Handled_Sequence_Of_Statements (Loc,
2542 Statements => New_List (Free_Stmt)));
2544 -- Generate:
2545 -- if BIPfinalizationmaster /= null then
2547 Cond :=
2548 Make_Op_Ne (Loc,
2549 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2550 Right_Opnd => Make_Null (Loc));
2552 -- For constrained or tagged results escalate the condition to
2553 -- include the allocation format. Generate:
2555 -- if BIPallocform > Secondary_Stack'Pos
2556 -- and then BIPfinalizationmaster /= null
2557 -- then
2559 if not Is_Constrained (Func_Typ)
2560 or else Is_Tagged_Type (Func_Typ)
2561 then
2562 declare
2563 Alloc : constant Entity_Id :=
2564 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2565 begin
2566 Cond :=
2567 Make_And_Then (Loc,
2568 Left_Opnd =>
2569 Make_Op_Gt (Loc,
2570 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2571 Right_Opnd =>
2572 Make_Integer_Literal (Loc,
2573 UI_From_Int
2574 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2576 Right_Opnd => Cond);
2577 end;
2578 end if;
2580 -- Generate:
2581 -- if <Cond> then
2582 -- <Free_Blk>
2583 -- end if;
2585 return
2586 Make_If_Statement (Loc,
2587 Condition => Cond,
2588 Then_Statements => New_List (Free_Blk));
2589 end Build_BIP_Cleanup_Stmts;
2591 --------------------
2592 -- Find_Last_Init --
2593 --------------------
2595 procedure Find_Last_Init
2596 (Last_Init : out Node_Id;
2597 Body_Insert : out Node_Id)
2599 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2600 -- Find the last initialization call within the statements of
2601 -- block Blk.
2603 function Is_Init_Call (N : Node_Id) return Boolean;
2604 -- Determine whether node N denotes one of the initialization
2605 -- procedures of types Init_Typ or Obj_Typ.
2607 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2608 -- Obtain the next statement which follows list member Stmt while
2609 -- ignoring artifacts related to access-before-elaboration checks.
2611 -----------------------------
2612 -- Find_Last_Init_In_Block --
2613 -----------------------------
2615 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2616 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2617 Stmt : Node_Id;
2619 begin
2620 -- Examine the individual statements of the block in reverse to
2621 -- locate the last initialization call.
2623 if Present (HSS) and then Present (Statements (HSS)) then
2624 Stmt := Last (Statements (HSS));
2625 while Present (Stmt) loop
2627 -- Peek inside nested blocks in case aborts are allowed
2629 if Nkind (Stmt) = N_Block_Statement then
2630 return Find_Last_Init_In_Block (Stmt);
2632 elsif Is_Init_Call (Stmt) then
2633 return Stmt;
2634 end if;
2636 Prev (Stmt);
2637 end loop;
2638 end if;
2640 return Empty;
2641 end Find_Last_Init_In_Block;
2643 ------------------
2644 -- Is_Init_Call --
2645 ------------------
2647 function Is_Init_Call (N : Node_Id) return Boolean is
2648 function Is_Init_Proc_Of
2649 (Subp_Id : Entity_Id;
2650 Typ : Entity_Id) return Boolean;
2651 -- Determine whether subprogram Subp_Id is a valid init proc of
2652 -- type Typ.
2654 ---------------------
2655 -- Is_Init_Proc_Of --
2656 ---------------------
2658 function Is_Init_Proc_Of
2659 (Subp_Id : Entity_Id;
2660 Typ : Entity_Id) return Boolean
2662 Deep_Init : Entity_Id := Empty;
2663 Prim_Init : Entity_Id := Empty;
2664 Type_Init : Entity_Id := Empty;
2666 begin
2667 -- Obtain all possible initialization routines of the
2668 -- related type and try to match the subprogram entity
2669 -- against one of them.
2671 -- Deep_Initialize
2673 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2675 -- Primitive Initialize
2677 if Is_Controlled (Typ) then
2678 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2680 if Present (Prim_Init) then
2681 Prim_Init := Ultimate_Alias (Prim_Init);
2682 end if;
2683 end if;
2685 -- Type initialization routine
2687 if Has_Non_Null_Base_Init_Proc (Typ) then
2688 Type_Init := Base_Init_Proc (Typ);
2689 end if;
2691 return
2692 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2693 or else
2694 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2695 or else
2696 (Present (Type_Init) and then Subp_Id = Type_Init);
2697 end Is_Init_Proc_Of;
2699 -- Local variables
2701 Call_Id : Entity_Id;
2703 -- Start of processing for Is_Init_Call
2705 begin
2706 if Nkind (N) = N_Procedure_Call_Statement
2707 and then Nkind (Name (N)) = N_Identifier
2708 then
2709 Call_Id := Entity (Name (N));
2711 -- Consider both the type of the object declaration and its
2712 -- related initialization type.
2714 return
2715 Is_Init_Proc_Of (Call_Id, Init_Typ)
2716 or else
2717 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2718 end if;
2720 return False;
2721 end Is_Init_Call;
2723 -----------------------------
2724 -- Next_Suitable_Statement --
2725 -----------------------------
2727 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2728 Result : Node_Id;
2730 begin
2731 -- Skip call markers and Program_Error raises installed by the
2732 -- ABE mechanism.
2734 Result := Next (Stmt);
2735 while Present (Result) loop
2736 if not Nkind_In (Result, N_Call_Marker,
2737 N_Raise_Program_Error)
2738 then
2739 exit;
2740 end if;
2742 Result := Next (Result);
2743 end loop;
2745 return Result;
2746 end Next_Suitable_Statement;
2748 -- Local variables
2750 Call : Node_Id;
2751 Stmt : Node_Id;
2752 Stmt_2 : Node_Id;
2754 Deep_Init_Found : Boolean := False;
2755 -- A flag set when a call to [Deep_]Initialize has been found
2757 -- Start of processing for Find_Last_Init
2759 begin
2760 Last_Init := Decl;
2761 Body_Insert := Empty;
2763 -- Object renamings and objects associated with controlled
2764 -- function results do not require initialization.
2766 if Has_No_Init then
2767 return;
2768 end if;
2770 Stmt := Next_Suitable_Statement (Decl);
2772 -- For an object with suppressed initialization, we check whether
2773 -- there is in fact no initialization expression. If there is not,
2774 -- then this is an object declaration that has been turned into a
2775 -- different object declaration that calls the build-in-place
2776 -- function in a 'Reference attribute, as in "F(...)'Reference".
2777 -- We search for that later object declaration, so that the
2778 -- Inc_Decl will be inserted after the call. Otherwise, if the
2779 -- call raises an exception, we will finalize the (uninitialized)
2780 -- object, which is wrong.
2782 if No_Initialization (Decl) then
2783 if No (Expression (Last_Init)) then
2784 loop
2785 Last_Init := Next (Last_Init);
2786 exit when No (Last_Init);
2787 exit when Nkind (Last_Init) = N_Object_Declaration
2788 and then Nkind (Expression (Last_Init)) = N_Reference
2789 and then Nkind (Prefix (Expression (Last_Init))) =
2790 N_Function_Call
2791 and then Is_Expanded_Build_In_Place_Call
2792 (Prefix (Expression (Last_Init)));
2793 end loop;
2794 end if;
2796 return;
2798 -- In all other cases the initialization calls follow the related
2799 -- object. The general structure of object initialization built by
2800 -- routine Default_Initialize_Object is as follows:
2802 -- [begin -- aborts allowed
2803 -- Abort_Defer;]
2804 -- Type_Init_Proc (Obj);
2805 -- [begin] -- exceptions allowed
2806 -- Deep_Initialize (Obj);
2807 -- [exception -- exceptions allowed
2808 -- when others =>
2809 -- Deep_Finalize (Obj, Self => False);
2810 -- raise;
2811 -- end;]
2812 -- [at end -- aborts allowed
2813 -- Abort_Undefer;
2814 -- end;]
2816 -- When aborts are allowed, the initialization calls are housed
2817 -- within a block.
2819 elsif Nkind (Stmt) = N_Block_Statement then
2820 Last_Init := Find_Last_Init_In_Block (Stmt);
2821 Body_Insert := Stmt;
2823 -- Otherwise the initialization calls follow the related object
2825 else
2826 Stmt_2 := Next_Suitable_Statement (Stmt);
2828 -- Check for an optional call to Deep_Initialize which may
2829 -- appear within a block depending on whether the object has
2830 -- controlled components.
2832 if Present (Stmt_2) then
2833 if Nkind (Stmt_2) = N_Block_Statement then
2834 Call := Find_Last_Init_In_Block (Stmt_2);
2836 if Present (Call) then
2837 Deep_Init_Found := True;
2838 Last_Init := Call;
2839 Body_Insert := Stmt_2;
2840 end if;
2842 elsif Is_Init_Call (Stmt_2) then
2843 Deep_Init_Found := True;
2844 Last_Init := Stmt_2;
2845 Body_Insert := Last_Init;
2846 end if;
2847 end if;
2849 -- If the object lacks a call to Deep_Initialize, then it must
2850 -- have a call to its related type init proc.
2852 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
2853 Last_Init := Stmt;
2854 Body_Insert := Last_Init;
2855 end if;
2856 end if;
2857 end Find_Last_Init;
2859 -- Local variables
2861 Body_Ins : Node_Id;
2862 Count_Ins : Node_Id;
2863 Fin_Call : Node_Id;
2864 Fin_Stmts : List_Id := No_List;
2865 Inc_Decl : Node_Id;
2866 Label : Node_Id;
2867 Label_Id : Entity_Id;
2868 Obj_Ref : Node_Id;
2870 -- Start of processing for Process_Object_Declaration
2872 begin
2873 -- Handle the object type and the reference to the object
2875 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2876 Obj_Typ := Base_Type (Etype (Obj_Id));
2878 loop
2879 if Is_Access_Type (Obj_Typ) then
2880 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2881 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2883 elsif Is_Concurrent_Type (Obj_Typ)
2884 and then Present (Corresponding_Record_Type (Obj_Typ))
2885 then
2886 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
2887 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2889 elsif Is_Private_Type (Obj_Typ)
2890 and then Present (Full_View (Obj_Typ))
2891 then
2892 Obj_Typ := Full_View (Obj_Typ);
2893 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2895 elsif Obj_Typ /= Base_Type (Obj_Typ) then
2896 Obj_Typ := Base_Type (Obj_Typ);
2897 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2899 else
2900 exit;
2901 end if;
2902 end loop;
2904 Set_Etype (Obj_Ref, Obj_Typ);
2906 -- Handle the initialization type of the object declaration
2908 Init_Typ := Obj_Typ;
2909 loop
2910 if Is_Private_Type (Init_Typ)
2911 and then Present (Full_View (Init_Typ))
2912 then
2913 Init_Typ := Full_View (Init_Typ);
2915 elsif Is_Untagged_Derivation (Init_Typ) then
2916 Init_Typ := Root_Type (Init_Typ);
2918 else
2919 exit;
2920 end if;
2921 end loop;
2923 -- Set a new value for the state counter and insert the statement
2924 -- after the object declaration. Generate:
2926 -- Counter := <value>;
2928 Inc_Decl :=
2929 Make_Assignment_Statement (Loc,
2930 Name => New_Occurrence_Of (Counter_Id, Loc),
2931 Expression => Make_Integer_Literal (Loc, Counter_Val));
2933 -- Insert the counter after all initialization has been done. The
2934 -- place of insertion depends on the context.
2936 if Ekind_In (Obj_Id, E_Constant, E_Variable) then
2938 -- The object is initialized by a build-in-place function call.
2939 -- The counter insertion point is after the function call.
2941 if Present (BIP_Initialization_Call (Obj_Id)) then
2942 Count_Ins := BIP_Initialization_Call (Obj_Id);
2943 Body_Ins := Empty;
2945 -- The object is initialized by an aggregate. Insert the counter
2946 -- after the last aggregate assignment.
2948 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
2949 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
2950 Body_Ins := Empty;
2952 -- In all other cases the counter is inserted after the last call
2953 -- to either [Deep_]Initialize or the type-specific init proc.
2955 else
2956 Find_Last_Init (Count_Ins, Body_Ins);
2957 end if;
2959 -- In all other cases the counter is inserted after the last call to
2960 -- either [Deep_]Initialize or the type-specific init proc.
2962 else
2963 Find_Last_Init (Count_Ins, Body_Ins);
2964 end if;
2966 -- If the Initialize function is null or trivial, the call will have
2967 -- been replaced with a null statement, in which case place counter
2968 -- declaration after object declaration itself.
2970 if No (Count_Ins) then
2971 Count_Ins := Decl;
2972 end if;
2974 Insert_After (Count_Ins, Inc_Decl);
2975 Analyze (Inc_Decl);
2977 -- If the current declaration is the last in the list, the finalizer
2978 -- body needs to be inserted after the set counter statement for the
2979 -- current object declaration. This is complicated by the fact that
2980 -- the set counter statement may appear in abort deferred block. In
2981 -- that case, the proper insertion place is after the block.
2983 if No (Finalizer_Insert_Nod) then
2985 -- Insertion after an abort deferred block
2987 if Present (Body_Ins) then
2988 Finalizer_Insert_Nod := Body_Ins;
2989 else
2990 Finalizer_Insert_Nod := Inc_Decl;
2991 end if;
2992 end if;
2994 -- Create the associated label with this object, generate:
2996 -- L<counter> : label;
2998 Label_Id :=
2999 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
3000 Set_Entity
3001 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
3002 Label := Make_Label (Loc, Label_Id);
3004 Prepend_To (Finalizer_Decls,
3005 Make_Implicit_Label_Declaration (Loc,
3006 Defining_Identifier => Entity (Label_Id),
3007 Label_Construct => Label));
3009 -- Create the associated jump with this object, generate:
3011 -- when <counter> =>
3012 -- goto L<counter>;
3014 Prepend_To (Jump_Alts,
3015 Make_Case_Statement_Alternative (Loc,
3016 Discrete_Choices => New_List (
3017 Make_Integer_Literal (Loc, Counter_Val)),
3018 Statements => New_List (
3019 Make_Goto_Statement (Loc,
3020 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
3022 -- Insert the jump destination, generate:
3024 -- <<L<counter>>>
3026 Append_To (Finalizer_Stmts, Label);
3028 -- Processing for simple protected objects. Such objects require
3029 -- manual finalization of their lock managers.
3031 if Is_Protected then
3032 if Is_Simple_Protected_Type (Obj_Typ) then
3033 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3035 if Present (Fin_Call) then
3036 Fin_Stmts := New_List (Fin_Call);
3037 end if;
3039 elsif Has_Simple_Protected_Object (Obj_Typ) then
3040 if Is_Record_Type (Obj_Typ) then
3041 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3042 elsif Is_Array_Type (Obj_Typ) then
3043 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3044 end if;
3045 end if;
3047 -- Generate:
3048 -- begin
3049 -- System.Tasking.Protected_Objects.Finalize_Protection
3050 -- (Obj._object);
3052 -- exception
3053 -- when others =>
3054 -- null;
3055 -- end;
3057 if Present (Fin_Stmts) and then Exceptions_OK then
3058 Fin_Stmts := New_List (
3059 Make_Block_Statement (Loc,
3060 Handled_Statement_Sequence =>
3061 Make_Handled_Sequence_Of_Statements (Loc,
3062 Statements => Fin_Stmts,
3064 Exception_Handlers => New_List (
3065 Make_Exception_Handler (Loc,
3066 Exception_Choices => New_List (
3067 Make_Others_Choice (Loc)),
3069 Statements => New_List (
3070 Make_Null_Statement (Loc)))))));
3071 end if;
3073 -- Processing for regular controlled objects
3075 else
3076 -- Generate:
3077 -- begin
3078 -- [Deep_]Finalize (Obj);
3080 -- exception
3081 -- when Id : others =>
3082 -- if not Raised then
3083 -- Raised := True;
3084 -- Save_Occurrence (E, Id);
3085 -- end if;
3086 -- end;
3088 Fin_Call :=
3089 Make_Final_Call (
3090 Obj_Ref => Obj_Ref,
3091 Typ => Obj_Typ);
3093 -- Guard against a missing [Deep_]Finalize when the object type
3094 -- was not properly frozen.
3096 if No (Fin_Call) then
3097 Fin_Call := Make_Null_Statement (Loc);
3098 end if;
3100 -- For CodePeer, the exception handlers normally generated here
3101 -- generate complex flowgraphs which result in capacity problems.
3102 -- Omitting these handlers for CodePeer is justified as follows:
3104 -- If a handler is dead, then omitting it is surely ok
3106 -- If a handler is live, then CodePeer should flag the
3107 -- potentially-exception-raising construct that causes it
3108 -- to be live. That is what we are interested in, not what
3109 -- happens after the exception is raised.
3111 if Exceptions_OK and not CodePeer_Mode then
3112 Fin_Stmts := New_List (
3113 Make_Block_Statement (Loc,
3114 Handled_Statement_Sequence =>
3115 Make_Handled_Sequence_Of_Statements (Loc,
3116 Statements => New_List (Fin_Call),
3118 Exception_Handlers => New_List (
3119 Build_Exception_Handler
3120 (Finalizer_Data, For_Package)))));
3122 -- When exception handlers are prohibited, the finalization call
3123 -- appears unprotected. Any exception raised during finalization
3124 -- will bypass the circuitry which ensures the cleanup of all
3125 -- remaining objects.
3127 else
3128 Fin_Stmts := New_List (Fin_Call);
3129 end if;
3131 -- If we are dealing with a return object of a build-in-place
3132 -- function, generate the following cleanup statements:
3134 -- if BIPallocfrom > Secondary_Stack'Pos
3135 -- and then BIPfinalizationmaster /= null
3136 -- then
3137 -- declare
3138 -- type Ptr_Typ is access Obj_Typ;
3139 -- for Ptr_Typ'Storage_Pool use
3140 -- Base_Pool (BIPfinalizationmaster.all).all;
3141 -- begin
3142 -- Free (Ptr_Typ (Temp));
3143 -- end;
3144 -- end if;
3146 -- The generated code effectively detaches the temporary from the
3147 -- caller finalization master and deallocates the object.
3149 if Is_Return_Object (Obj_Id) then
3150 declare
3151 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
3152 begin
3153 if Is_Build_In_Place_Function (Func_Id)
3154 and then Needs_BIP_Finalization_Master (Func_Id)
3155 then
3156 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3157 end if;
3158 end;
3159 end if;
3161 if Ekind_In (Obj_Id, E_Constant, E_Variable)
3162 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3163 then
3164 -- Temporaries created for the purpose of "exporting" a
3165 -- transient object out of an Expression_With_Actions (EWA)
3166 -- need guards. The following illustrates the usage of such
3167 -- temporaries.
3169 -- Access_Typ : access [all] Obj_Typ;
3170 -- Temp : Access_Typ := null;
3171 -- <Counter> := ...;
3173 -- do
3174 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3175 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3176 -- <or>
3177 -- Temp := Ctrl_Trans'Unchecked_Access;
3178 -- in ... end;
3180 -- The finalization machinery does not process EWA nodes as
3181 -- this may lead to premature finalization of expressions. Note
3182 -- that Temp is marked as being properly initialized regardless
3183 -- of whether the initialization of Ctrl_Trans succeeded. Since
3184 -- a failed initialization may leave Temp with a value of null,
3185 -- add a guard to handle this case:
3187 -- if Obj /= null then
3188 -- <object finalization statements>
3189 -- end if;
3191 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3192 N_Object_Declaration
3193 then
3194 Fin_Stmts := New_List (
3195 Make_If_Statement (Loc,
3196 Condition =>
3197 Make_Op_Ne (Loc,
3198 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3199 Right_Opnd => Make_Null (Loc)),
3200 Then_Statements => Fin_Stmts));
3202 -- Return objects use a flag to aid in processing their
3203 -- potential finalization when the enclosing function fails
3204 -- to return properly. Generate:
3206 -- if not Flag then
3207 -- <object finalization statements>
3208 -- end if;
3210 else
3211 Fin_Stmts := New_List (
3212 Make_If_Statement (Loc,
3213 Condition =>
3214 Make_Op_Not (Loc,
3215 Right_Opnd =>
3216 New_Occurrence_Of
3217 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3219 Then_Statements => Fin_Stmts));
3220 end if;
3221 end if;
3222 end if;
3224 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3226 -- Since the declarations are examined in reverse, the state counter
3227 -- must be decremented in order to keep with the true position of
3228 -- objects.
3230 Counter_Val := Counter_Val - 1;
3231 end Process_Object_Declaration;
3233 -------------------------------------
3234 -- Process_Tagged_Type_Declaration --
3235 -------------------------------------
3237 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3238 Typ : constant Entity_Id := Defining_Identifier (Decl);
3239 DT_Ptr : constant Entity_Id :=
3240 Node (First_Elmt (Access_Disp_Table (Typ)));
3241 begin
3242 -- Generate:
3243 -- Ada.Tags.Unregister_Tag (<Typ>P);
3245 Append_To (Tagged_Type_Stmts,
3246 Make_Procedure_Call_Statement (Loc,
3247 Name =>
3248 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3249 Parameter_Associations => New_List (
3250 New_Occurrence_Of (DT_Ptr, Loc))));
3251 end Process_Tagged_Type_Declaration;
3253 -- Start of processing for Build_Finalizer
3255 begin
3256 Fin_Id := Empty;
3258 -- Do not perform this expansion in SPARK mode because it is not
3259 -- necessary.
3261 if GNATprove_Mode then
3262 return;
3263 end if;
3265 -- Step 1: Extract all lists which may contain controlled objects or
3266 -- library-level tagged types.
3268 if For_Package_Spec then
3269 Decls := Visible_Declarations (Specification (N));
3270 Priv_Decls := Private_Declarations (Specification (N));
3272 -- Retrieve the package spec id
3274 Spec_Id := Defining_Unit_Name (Specification (N));
3276 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3277 Spec_Id := Defining_Identifier (Spec_Id);
3278 end if;
3280 -- Accept statement, block, entry body, package body, protected body,
3281 -- subprogram body or task body.
3283 else
3284 Decls := Declarations (N);
3285 HSS := Handled_Statement_Sequence (N);
3287 if Present (HSS) then
3288 if Present (Statements (HSS)) then
3289 Stmts := Statements (HSS);
3290 end if;
3292 if Present (At_End_Proc (HSS)) then
3293 Prev_At_End := At_End_Proc (HSS);
3294 end if;
3295 end if;
3297 -- Retrieve the package spec id for package bodies
3299 if For_Package_Body then
3300 Spec_Id := Corresponding_Spec (N);
3301 end if;
3302 end if;
3304 -- Do not process nested packages since those are handled by the
3305 -- enclosing scope's finalizer. Do not process non-expanded package
3306 -- instantiations since those will be re-analyzed and re-expanded.
3308 if For_Package
3309 and then
3310 (not Is_Library_Level_Entity (Spec_Id)
3312 -- Nested packages are considered to be library level entities,
3313 -- but do not need to be processed separately. True library level
3314 -- packages have a scope value of 1.
3316 or else Scope_Depth_Value (Spec_Id) /= Uint_1
3317 or else (Is_Generic_Instance (Spec_Id)
3318 and then Package_Instantiation (Spec_Id) /= N))
3319 then
3320 return;
3321 end if;
3323 -- Step 2: Object [pre]processing
3325 if For_Package then
3327 -- Preprocess the visible declarations now in order to obtain the
3328 -- correct number of controlled object by the time the private
3329 -- declarations are processed.
3331 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3333 -- From all the possible contexts, only package specifications may
3334 -- have private declarations.
3336 if For_Package_Spec then
3337 Process_Declarations
3338 (Priv_Decls, Preprocess => True, Top_Level => True);
3339 end if;
3341 -- The current context may lack controlled objects, but require some
3342 -- other form of completion (task termination for instance). In such
3343 -- cases, the finalizer must be created and carry the additional
3344 -- statements.
3346 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3347 Build_Components;
3348 end if;
3350 -- The preprocessing has determined that the context has controlled
3351 -- objects or library-level tagged types.
3353 if Has_Ctrl_Objs or Has_Tagged_Types then
3355 -- Private declarations are processed first in order to preserve
3356 -- possible dependencies between public and private objects.
3358 if For_Package_Spec then
3359 Process_Declarations (Priv_Decls);
3360 end if;
3362 Process_Declarations (Decls);
3363 end if;
3365 -- Non-package case
3367 else
3368 -- Preprocess both declarations and statements
3370 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3371 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3373 -- At this point it is known that N has controlled objects. Ensure
3374 -- that N has a declarative list since the finalizer spec will be
3375 -- attached to it.
3377 if Has_Ctrl_Objs and then No (Decls) then
3378 Set_Declarations (N, New_List);
3379 Decls := Declarations (N);
3380 Spec_Decls := Decls;
3381 end if;
3383 -- The current context may lack controlled objects, but require some
3384 -- other form of completion (task termination for instance). In such
3385 -- cases, the finalizer must be created and carry the additional
3386 -- statements.
3388 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3389 Build_Components;
3390 end if;
3392 if Has_Ctrl_Objs or Has_Tagged_Types then
3393 Process_Declarations (Stmts);
3394 Process_Declarations (Decls);
3395 end if;
3396 end if;
3398 -- Step 3: Finalizer creation
3400 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3401 Create_Finalizer;
3402 end if;
3403 end Build_Finalizer;
3405 --------------------------
3406 -- Build_Finalizer_Call --
3407 --------------------------
3409 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3410 Is_Prot_Body : constant Boolean :=
3411 Nkind (N) = N_Subprogram_Body
3412 and then Is_Protected_Subprogram_Body (N);
3413 -- Determine whether N denotes the protected version of a subprogram
3414 -- which belongs to a protected type.
3416 Loc : constant Source_Ptr := Sloc (N);
3417 HSS : Node_Id;
3419 begin
3420 -- Do not perform this expansion in SPARK mode because we do not create
3421 -- finalizers in the first place.
3423 if GNATprove_Mode then
3424 return;
3425 end if;
3427 -- The At_End handler should have been assimilated by the finalizer
3429 HSS := Handled_Statement_Sequence (N);
3430 pragma Assert (No (At_End_Proc (HSS)));
3432 -- If the construct to be cleaned up is a protected subprogram body, the
3433 -- finalizer call needs to be associated with the block which wraps the
3434 -- unprotected version of the subprogram. The following illustrates this
3435 -- scenario:
3437 -- procedure Prot_SubpP is
3438 -- procedure finalizer is
3439 -- begin
3440 -- Service_Entries (Prot_Obj);
3441 -- Abort_Undefer;
3442 -- end finalizer;
3444 -- begin
3445 -- . . .
3446 -- begin
3447 -- Prot_SubpN (Prot_Obj);
3448 -- at end
3449 -- finalizer;
3450 -- end;
3451 -- end Prot_SubpP;
3453 if Is_Prot_Body then
3454 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3456 -- An At_End handler and regular exception handlers cannot coexist in
3457 -- the same statement sequence. Wrap the original statements in a block.
3459 elsif Present (Exception_Handlers (HSS)) then
3460 declare
3461 End_Lab : constant Node_Id := End_Label (HSS);
3462 Block : Node_Id;
3464 begin
3465 Block :=
3466 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3468 Set_Handled_Statement_Sequence (N,
3469 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3471 HSS := Handled_Statement_Sequence (N);
3472 Set_End_Label (HSS, End_Lab);
3473 end;
3474 end if;
3476 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3478 Analyze (At_End_Proc (HSS));
3479 Expand_At_End_Handler (HSS, Empty);
3480 end Build_Finalizer_Call;
3482 ---------------------
3483 -- Build_Late_Proc --
3484 ---------------------
3486 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3487 begin
3488 for Final_Prim in Name_Of'Range loop
3489 if Name_Of (Final_Prim) = Nam then
3490 Set_TSS (Typ,
3491 Make_Deep_Proc
3492 (Prim => Final_Prim,
3493 Typ => Typ,
3494 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3495 end if;
3496 end loop;
3497 end Build_Late_Proc;
3499 -------------------------------
3500 -- Build_Object_Declarations --
3501 -------------------------------
3503 procedure Build_Object_Declarations
3504 (Data : out Finalization_Exception_Data;
3505 Decls : List_Id;
3506 Loc : Source_Ptr;
3507 For_Package : Boolean := False)
3509 Decl : Node_Id;
3511 Dummy : Entity_Id;
3512 -- This variable captures an unused dummy internal entity, see the
3513 -- comment associated with its use.
3515 begin
3516 pragma Assert (Decls /= No_List);
3518 -- Always set the proper location as it may be needed even when
3519 -- exception propagation is forbidden.
3521 Data.Loc := Loc;
3523 if Restriction_Active (No_Exception_Propagation) then
3524 Data.Abort_Id := Empty;
3525 Data.E_Id := Empty;
3526 Data.Raised_Id := Empty;
3527 return;
3528 end if;
3530 Data.Raised_Id := Make_Temporary (Loc, 'R');
3532 -- In certain scenarios, finalization can be triggered by an abort. If
3533 -- the finalization itself fails and raises an exception, the resulting
3534 -- Program_Error must be supressed and replaced by an abort signal. In
3535 -- order to detect this scenario, save the state of entry into the
3536 -- finalization code.
3538 -- This is not needed for library-level finalizers as they are called by
3539 -- the environment task and cannot be aborted.
3541 if not For_Package then
3542 if Abort_Allowed then
3543 Data.Abort_Id := Make_Temporary (Loc, 'A');
3545 -- Generate:
3546 -- Abort_Id : constant Boolean := <A_Expr>;
3548 Append_To (Decls,
3549 Make_Object_Declaration (Loc,
3550 Defining_Identifier => Data.Abort_Id,
3551 Constant_Present => True,
3552 Object_Definition =>
3553 New_Occurrence_Of (Standard_Boolean, Loc),
3554 Expression =>
3555 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3557 -- Abort is not required
3559 else
3560 -- Generate a dummy entity to ensure that the internal symbols are
3561 -- in sync when a unit is compiled with and without aborts.
3563 Dummy := Make_Temporary (Loc, 'A');
3564 Data.Abort_Id := Empty;
3565 end if;
3567 -- Library-level finalizers
3569 else
3570 Data.Abort_Id := Empty;
3571 end if;
3573 if Exception_Extra_Info then
3574 Data.E_Id := Make_Temporary (Loc, 'E');
3576 -- Generate:
3577 -- E_Id : Exception_Occurrence;
3579 Decl :=
3580 Make_Object_Declaration (Loc,
3581 Defining_Identifier => Data.E_Id,
3582 Object_Definition =>
3583 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3584 Set_No_Initialization (Decl);
3586 Append_To (Decls, Decl);
3588 else
3589 Data.E_Id := Empty;
3590 end if;
3592 -- Generate:
3593 -- Raised_Id : Boolean := False;
3595 Append_To (Decls,
3596 Make_Object_Declaration (Loc,
3597 Defining_Identifier => Data.Raised_Id,
3598 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3599 Expression => New_Occurrence_Of (Standard_False, Loc)));
3600 end Build_Object_Declarations;
3602 ---------------------------
3603 -- Build_Raise_Statement --
3604 ---------------------------
3606 function Build_Raise_Statement
3607 (Data : Finalization_Exception_Data) return Node_Id
3609 Stmt : Node_Id;
3610 Expr : Node_Id;
3612 begin
3613 -- Standard run-time use the specialized routine
3614 -- Raise_From_Controlled_Operation.
3616 if Exception_Extra_Info
3617 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3618 then
3619 Stmt :=
3620 Make_Procedure_Call_Statement (Data.Loc,
3621 Name =>
3622 New_Occurrence_Of
3623 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3624 Parameter_Associations =>
3625 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3627 -- Restricted run-time: exception messages are not supported and hence
3628 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3629 -- instead.
3631 else
3632 Stmt :=
3633 Make_Raise_Program_Error (Data.Loc,
3634 Reason => PE_Finalize_Raised_Exception);
3635 end if;
3637 -- Generate:
3639 -- Raised_Id and then not Abort_Id
3640 -- <or>
3641 -- Raised_Id
3643 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3645 if Present (Data.Abort_Id) then
3646 Expr := Make_And_Then (Data.Loc,
3647 Left_Opnd => Expr,
3648 Right_Opnd =>
3649 Make_Op_Not (Data.Loc,
3650 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3651 end if;
3653 -- Generate:
3655 -- if Raised_Id and then not Abort_Id then
3656 -- Raise_From_Controlled_Operation (E_Id);
3657 -- <or>
3658 -- raise Program_Error; -- restricted runtime
3659 -- end if;
3661 return
3662 Make_If_Statement (Data.Loc,
3663 Condition => Expr,
3664 Then_Statements => New_List (Stmt));
3665 end Build_Raise_Statement;
3667 -----------------------------
3668 -- Build_Record_Deep_Procs --
3669 -----------------------------
3671 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3672 begin
3673 Set_TSS (Typ,
3674 Make_Deep_Proc
3675 (Prim => Initialize_Case,
3676 Typ => Typ,
3677 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3679 if not Is_Limited_View (Typ) then
3680 Set_TSS (Typ,
3681 Make_Deep_Proc
3682 (Prim => Adjust_Case,
3683 Typ => Typ,
3684 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3685 end if;
3687 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3688 -- suppressed since these routine will not be used.
3690 if not Restriction_Active (No_Finalization) then
3691 Set_TSS (Typ,
3692 Make_Deep_Proc
3693 (Prim => Finalize_Case,
3694 Typ => Typ,
3695 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3697 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3699 if not CodePeer_Mode then
3700 Set_TSS (Typ,
3701 Make_Deep_Proc
3702 (Prim => Address_Case,
3703 Typ => Typ,
3704 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3705 end if;
3706 end if;
3707 end Build_Record_Deep_Procs;
3709 -------------------
3710 -- Cleanup_Array --
3711 -------------------
3713 function Cleanup_Array
3714 (N : Node_Id;
3715 Obj : Node_Id;
3716 Typ : Entity_Id) return List_Id
3718 Loc : constant Source_Ptr := Sloc (N);
3719 Index_List : constant List_Id := New_List;
3721 function Free_Component return List_Id;
3722 -- Generate the code to finalize the task or protected subcomponents
3723 -- of a single component of the array.
3725 function Free_One_Dimension (Dim : Int) return List_Id;
3726 -- Generate a loop over one dimension of the array
3728 --------------------
3729 -- Free_Component --
3730 --------------------
3732 function Free_Component return List_Id is
3733 Stmts : List_Id := New_List;
3734 Tsk : Node_Id;
3735 C_Typ : constant Entity_Id := Component_Type (Typ);
3737 begin
3738 -- Component type is known to contain tasks or protected objects
3740 Tsk :=
3741 Make_Indexed_Component (Loc,
3742 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3743 Expressions => Index_List);
3745 Set_Etype (Tsk, C_Typ);
3747 if Is_Task_Type (C_Typ) then
3748 Append_To (Stmts, Cleanup_Task (N, Tsk));
3750 elsif Is_Simple_Protected_Type (C_Typ) then
3751 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3753 elsif Is_Record_Type (C_Typ) then
3754 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3756 elsif Is_Array_Type (C_Typ) then
3757 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3758 end if;
3760 return Stmts;
3761 end Free_Component;
3763 ------------------------
3764 -- Free_One_Dimension --
3765 ------------------------
3767 function Free_One_Dimension (Dim : Int) return List_Id is
3768 Index : Entity_Id;
3770 begin
3771 if Dim > Number_Dimensions (Typ) then
3772 return Free_Component;
3774 -- Here we generate the required loop
3776 else
3777 Index := Make_Temporary (Loc, 'J');
3778 Append (New_Occurrence_Of (Index, Loc), Index_List);
3780 return New_List (
3781 Make_Implicit_Loop_Statement (N,
3782 Identifier => Empty,
3783 Iteration_Scheme =>
3784 Make_Iteration_Scheme (Loc,
3785 Loop_Parameter_Specification =>
3786 Make_Loop_Parameter_Specification (Loc,
3787 Defining_Identifier => Index,
3788 Discrete_Subtype_Definition =>
3789 Make_Attribute_Reference (Loc,
3790 Prefix => Duplicate_Subexpr (Obj),
3791 Attribute_Name => Name_Range,
3792 Expressions => New_List (
3793 Make_Integer_Literal (Loc, Dim))))),
3794 Statements => Free_One_Dimension (Dim + 1)));
3795 end if;
3796 end Free_One_Dimension;
3798 -- Start of processing for Cleanup_Array
3800 begin
3801 return Free_One_Dimension (1);
3802 end Cleanup_Array;
3804 --------------------
3805 -- Cleanup_Record --
3806 --------------------
3808 function Cleanup_Record
3809 (N : Node_Id;
3810 Obj : Node_Id;
3811 Typ : Entity_Id) return List_Id
3813 Loc : constant Source_Ptr := Sloc (N);
3814 Tsk : Node_Id;
3815 Comp : Entity_Id;
3816 Stmts : constant List_Id := New_List;
3817 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3819 begin
3820 if Has_Discriminants (U_Typ)
3821 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3822 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3823 and then
3824 Present
3825 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3826 then
3827 -- For now, do not attempt to free a component that may appear in a
3828 -- variant, and instead issue a warning. Doing this "properly" would
3829 -- require building a case statement and would be quite a mess. Note
3830 -- that the RM only requires that free "work" for the case of a task
3831 -- access value, so already we go way beyond this in that we deal
3832 -- with the array case and non-discriminated record cases.
3834 Error_Msg_N
3835 ("task/protected object in variant record will not be freed??", N);
3836 return New_List (Make_Null_Statement (Loc));
3837 end if;
3839 Comp := First_Component (Typ);
3840 while Present (Comp) loop
3841 if Has_Task (Etype (Comp))
3842 or else Has_Simple_Protected_Object (Etype (Comp))
3843 then
3844 Tsk :=
3845 Make_Selected_Component (Loc,
3846 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3847 Selector_Name => New_Occurrence_Of (Comp, Loc));
3848 Set_Etype (Tsk, Etype (Comp));
3850 if Is_Task_Type (Etype (Comp)) then
3851 Append_To (Stmts, Cleanup_Task (N, Tsk));
3853 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3854 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3856 elsif Is_Record_Type (Etype (Comp)) then
3858 -- Recurse, by generating the prefix of the argument to
3859 -- the eventual cleanup call.
3861 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3863 elsif Is_Array_Type (Etype (Comp)) then
3864 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3865 end if;
3866 end if;
3868 Next_Component (Comp);
3869 end loop;
3871 return Stmts;
3872 end Cleanup_Record;
3874 ------------------------------
3875 -- Cleanup_Protected_Object --
3876 ------------------------------
3878 function Cleanup_Protected_Object
3879 (N : Node_Id;
3880 Ref : Node_Id) return Node_Id
3882 Loc : constant Source_Ptr := Sloc (N);
3884 begin
3885 -- For restricted run-time libraries (Ravenscar), tasks are
3886 -- non-terminating, and protected objects can only appear at library
3887 -- level, so we do not want finalization of protected objects.
3889 if Restricted_Profile then
3890 return Empty;
3892 else
3893 return
3894 Make_Procedure_Call_Statement (Loc,
3895 Name =>
3896 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
3897 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3898 end if;
3899 end Cleanup_Protected_Object;
3901 ------------------
3902 -- Cleanup_Task --
3903 ------------------
3905 function Cleanup_Task
3906 (N : Node_Id;
3907 Ref : Node_Id) return Node_Id
3909 Loc : constant Source_Ptr := Sloc (N);
3911 begin
3912 -- For restricted run-time libraries (Ravenscar), tasks are
3913 -- non-terminating and they can only appear at library level, so we do
3914 -- not want finalization of task objects.
3916 if Restricted_Profile then
3917 return Empty;
3919 else
3920 return
3921 Make_Procedure_Call_Statement (Loc,
3922 Name =>
3923 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
3924 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3925 end if;
3926 end Cleanup_Task;
3928 ------------------------------
3929 -- Check_Visibly_Controlled --
3930 ------------------------------
3932 procedure Check_Visibly_Controlled
3933 (Prim : Final_Primitives;
3934 Typ : Entity_Id;
3935 E : in out Entity_Id;
3936 Cref : in out Node_Id)
3938 Parent_Type : Entity_Id;
3939 Op : Entity_Id;
3941 begin
3942 if Is_Derived_Type (Typ)
3943 and then Comes_From_Source (E)
3944 and then not Present (Overridden_Operation (E))
3945 then
3946 -- We know that the explicit operation on the type does not override
3947 -- the inherited operation of the parent, and that the derivation
3948 -- is from a private type that is not visibly controlled.
3950 Parent_Type := Etype (Typ);
3951 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
3953 if Present (Op) then
3954 E := Op;
3956 -- Wrap the object to be initialized into the proper
3957 -- unchecked conversion, to be compatible with the operation
3958 -- to be called.
3960 if Nkind (Cref) = N_Unchecked_Type_Conversion then
3961 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
3962 else
3963 Cref := Unchecked_Convert_To (Parent_Type, Cref);
3964 end if;
3965 end if;
3966 end if;
3967 end Check_Visibly_Controlled;
3969 ------------------
3970 -- Convert_View --
3971 ------------------
3973 function Convert_View
3974 (Proc : Entity_Id;
3975 Arg : Node_Id;
3976 Ind : Pos := 1) return Node_Id
3978 Fent : Entity_Id := First_Entity (Proc);
3979 Ftyp : Entity_Id;
3980 Atyp : Entity_Id;
3982 begin
3983 for J in 2 .. Ind loop
3984 Next_Entity (Fent);
3985 end loop;
3987 Ftyp := Etype (Fent);
3989 if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
3990 Atyp := Entity (Subtype_Mark (Arg));
3991 else
3992 Atyp := Etype (Arg);
3993 end if;
3995 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
3996 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
3998 elsif Ftyp /= Atyp
3999 and then Present (Atyp)
4000 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
4001 and then Base_Type (Underlying_Type (Atyp)) =
4002 Base_Type (Underlying_Type (Ftyp))
4003 then
4004 return Unchecked_Convert_To (Ftyp, Arg);
4006 -- If the argument is already a conversion, as generated by
4007 -- Make_Init_Call, set the target type to the type of the formal
4008 -- directly, to avoid spurious typing problems.
4010 elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
4011 and then not Is_Class_Wide_Type (Atyp)
4012 then
4013 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
4014 Set_Etype (Arg, Ftyp);
4015 return Arg;
4017 -- Otherwise, introduce a conversion when the designated object
4018 -- has a type derived from the formal of the controlled routine.
4020 elsif Is_Private_Type (Ftyp)
4021 and then Present (Atyp)
4022 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
4023 then
4024 return Unchecked_Convert_To (Ftyp, Arg);
4026 else
4027 return Arg;
4028 end if;
4029 end Convert_View;
4031 -------------------------------
4032 -- CW_Or_Has_Controlled_Part --
4033 -------------------------------
4035 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
4036 begin
4037 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
4038 end CW_Or_Has_Controlled_Part;
4040 ------------------------
4041 -- Enclosing_Function --
4042 ------------------------
4044 function Enclosing_Function (E : Entity_Id) return Entity_Id is
4045 Func_Id : Entity_Id;
4047 begin
4048 Func_Id := E;
4049 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
4050 if Ekind (Func_Id) = E_Function then
4051 return Func_Id;
4052 end if;
4054 Func_Id := Scope (Func_Id);
4055 end loop;
4057 return Empty;
4058 end Enclosing_Function;
4060 -------------------------------
4061 -- Establish_Transient_Scope --
4062 -------------------------------
4064 -- This procedure is called each time a transient block has to be inserted
4065 -- that is to say for each call to a function with unconstrained or tagged
4066 -- result. It creates a new scope on the scope stack in order to enclose
4067 -- all transient variables generated.
4069 procedure Establish_Transient_Scope
4070 (N : Node_Id;
4071 Manage_Sec_Stack : Boolean)
4073 procedure Create_Transient_Scope (Constr : Node_Id);
4074 -- Place a new scope on the scope stack in order to service construct
4075 -- Constr. The new scope may also manage the secondary stack.
4077 procedure Delegate_Sec_Stack_Management;
4078 -- Move the management of the secondary stack to the nearest enclosing
4079 -- suitable scope.
4081 function Find_Enclosing_Transient_Scope return Entity_Id;
4082 -- Examine the scope stack looking for the nearest enclosing transient
4083 -- scope. Return Empty if no such scope exists.
4085 function Is_OK_Construct (Constr : Node_Id) return Boolean;
4086 -- Determine whether arbitrary node Constr is a suitable construct which
4087 -- requires handling by a transient scope.
4089 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
4090 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4092 ----------------------------
4093 -- Create_Transient_Scope --
4094 ----------------------------
4096 procedure Create_Transient_Scope (Constr : Node_Id) is
4097 Loc : constant Source_Ptr := Sloc (N);
4099 Iter_Loop : Entity_Id;
4100 Trans_Scop : Entity_Id;
4102 begin
4103 Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4104 Set_Etype (Trans_Scop, Standard_Void_Type);
4106 Push_Scope (Trans_Scop);
4107 Set_Node_To_Be_Wrapped (Constr);
4108 Set_Scope_Is_Transient;
4110 -- The transient scope must also manage the secondary stack
4112 if Manage_Sec_Stack then
4113 Set_Uses_Sec_Stack (Trans_Scop);
4114 Check_Restriction (No_Secondary_Stack, N);
4116 -- The expansion of iterator loops generates references to objects
4117 -- in order to extract elements from a container:
4119 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4120 -- Obj : <object type> renames Ref.all.Element.all;
4122 -- These references are controlled and returned on the secondary
4123 -- stack. A new reference is created at each iteration of the loop
4124 -- and as a result it must be finalized and the space occupied by
4125 -- it on the secondary stack reclaimed at the end of the current
4126 -- iteration.
4128 -- When the context that requires a transient scope is a call to
4129 -- routine Reference, the node to be wrapped is the source object:
4131 -- for Obj of Container loop
4133 -- Routine Wrap_Transient_Declaration however does not generate a
4134 -- physical block as wrapping a declaration will kill it too ealy.
4135 -- To handle this peculiar case, mark the related iterator loop as
4136 -- requiring the secondary stack. This signals the finalization
4137 -- machinery to manage the secondary stack (see routine
4138 -- Process_Statements_For_Controlled_Objects).
4140 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
4142 if Present (Iter_Loop) then
4143 Set_Uses_Sec_Stack (Iter_Loop);
4144 end if;
4145 end if;
4147 if Debug_Flag_W then
4148 Write_Str (" <Transient>");
4149 Write_Eol;
4150 end if;
4151 end Create_Transient_Scope;
4153 -----------------------------------
4154 -- Delegate_Sec_Stack_Management --
4155 -----------------------------------
4157 procedure Delegate_Sec_Stack_Management is
4158 Scop_Id : Entity_Id;
4159 Scop_Rec : Scope_Stack_Entry;
4161 begin
4162 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4163 Scop_Rec := Scope_Stack.Table (Index);
4164 Scop_Id := Scop_Rec.Entity;
4166 -- Prevent the search from going too far or within the scope space
4167 -- of another unit.
4169 if Scop_Id = Standard_Standard then
4170 return;
4172 -- No transient scope should be encountered during the traversal
4173 -- because Establish_Transient_Scope should have already handled
4174 -- this case.
4176 elsif Scop_Rec.Is_Transient then
4177 pragma Assert (False);
4178 return;
4180 -- The construct which requires secondary stack management is
4181 -- always enclosed by a package or subprogram scope.
4183 elsif Is_Package_Or_Subprogram (Scop_Id) then
4184 Set_Uses_Sec_Stack (Scop_Id);
4185 Check_Restriction (No_Secondary_Stack, N);
4187 return;
4188 end if;
4189 end loop;
4191 -- At this point no suitable scope was found. This should never occur
4192 -- because a construct is always enclosed by a compilation unit which
4193 -- has a scope.
4195 pragma Assert (False);
4196 end Delegate_Sec_Stack_Management;
4198 ------------------------------------
4199 -- Find_Enclosing_Transient_Scope --
4200 ------------------------------------
4202 function Find_Enclosing_Transient_Scope return Entity_Id is
4203 Scop_Id : Entity_Id;
4204 Scop_Rec : Scope_Stack_Entry;
4206 begin
4207 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4208 Scop_Rec := Scope_Stack.Table (Index);
4209 Scop_Id := Scop_Rec.Entity;
4211 -- Prevent the search from going too far or within the scope space
4212 -- of another unit.
4214 if Scop_Id = Standard_Standard
4215 or else Is_Package_Or_Subprogram (Scop_Id)
4216 then
4217 exit;
4219 elsif Scop_Rec.Is_Transient then
4220 return Scop_Id;
4221 end if;
4222 end loop;
4224 return Empty;
4225 end Find_Enclosing_Transient_Scope;
4227 ---------------------
4228 -- Is_OK_Construct --
4229 ---------------------
4231 function Is_OK_Construct (Constr : Node_Id) return Boolean is
4232 begin
4233 -- Nothing to do when there is no construct to consider
4235 if No (Constr) then
4236 return False;
4238 -- Nothing to do when the construct is an iteration scheme or an Ada
4239 -- 2012 iterator because the expression is one of the bounds, and the
4240 -- expansion will create an explicit declaration for it (see routine
4241 -- Analyze_Iteration_Scheme).
4243 elsif Nkind_In (Constr, N_Iteration_Scheme,
4244 N_Iterator_Specification)
4245 then
4246 return False;
4248 -- Nothing to do in formal verification mode when the construct is
4249 -- pragma Check, because the pragma remains unexpanded.
4251 elsif GNATprove_Mode
4252 and then Nkind (Constr) = N_Pragma
4253 and then Get_Pragma_Id (Constr) = Pragma_Check
4254 then
4255 return False;
4256 end if;
4258 return True;
4259 end Is_OK_Construct;
4261 ------------------------------
4262 -- Is_Package_Or_Subprogram --
4263 ------------------------------
4265 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
4266 begin
4267 return Ekind_In (Id, E_Entry,
4268 E_Entry_Family,
4269 E_Function,
4270 E_Package,
4271 E_Procedure,
4272 E_Subprogram_Body);
4273 end Is_Package_Or_Subprogram;
4275 -- Local variables
4277 Scop_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
4278 Constr : Node_Id;
4280 -- Start of processing for Establish_Transient_Scope
4282 begin
4283 -- Do not create a new transient scope if there is an existing transient
4284 -- scope on the stack.
4286 if Present (Scop_Id) then
4288 -- If the transient scope was requested for purposes of managing the
4289 -- secondary stack, then the existing scope must perform this task.
4291 if Manage_Sec_Stack then
4292 Set_Uses_Sec_Stack (Scop_Id);
4293 end if;
4295 return;
4296 end if;
4298 -- At this point it is known that the scope stack is free of transient
4299 -- scopes. Locate the proper construct which must be serviced by a new
4300 -- transient scope.
4302 Constr := Find_Node_To_Be_Wrapped (N);
4304 if Is_OK_Construct (Constr) then
4305 Create_Transient_Scope (Constr);
4307 -- Otherwise there is no suitable construct which requires handling by
4308 -- a transient scope. If the transient scope was requested for purposes
4309 -- of managing the secondary stack, delegate the work to an enclosing
4310 -- scope.
4312 elsif Manage_Sec_Stack then
4313 Delegate_Sec_Stack_Management;
4314 end if;
4315 end Establish_Transient_Scope;
4317 ----------------------------
4318 -- Expand_Cleanup_Actions --
4319 ----------------------------
4321 procedure Expand_Cleanup_Actions (N : Node_Id) is
4322 pragma Assert (Nkind_In (N, N_Block_Statement,
4323 N_Entry_Body,
4324 N_Extended_Return_Statement,
4325 N_Subprogram_Body,
4326 N_Task_Body));
4328 Scop : constant Entity_Id := Current_Scope;
4330 Is_Asynchronous_Call : constant Boolean :=
4331 Nkind (N) = N_Block_Statement
4332 and then Is_Asynchronous_Call_Block (N);
4333 Is_Master : constant Boolean :=
4334 Nkind (N) /= N_Extended_Return_Statement
4335 and then Nkind (N) /= N_Entry_Body
4336 and then Is_Task_Master (N);
4337 Is_Protected_Subp_Body : constant Boolean :=
4338 Nkind (N) = N_Subprogram_Body
4339 and then Is_Protected_Subprogram_Body (N);
4340 Is_Task_Allocation : constant Boolean :=
4341 Nkind (N) = N_Block_Statement
4342 and then Is_Task_Allocation_Block (N);
4343 Is_Task_Body : constant Boolean :=
4344 Nkind (Original_Node (N)) = N_Task_Body;
4345 Needs_Sec_Stack_Mark : constant Boolean :=
4346 Uses_Sec_Stack (Scop)
4347 and then
4348 not Sec_Stack_Needed_For_Return (Scop);
4349 Needs_Custom_Cleanup : constant Boolean :=
4350 Nkind (N) = N_Block_Statement
4351 and then Present (Cleanup_Actions (N));
4353 Actions_Required : constant Boolean :=
4354 Requires_Cleanup_Actions (N, True)
4355 or else Is_Asynchronous_Call
4356 or else Is_Master
4357 or else Is_Protected_Subp_Body
4358 or else Is_Task_Allocation
4359 or else Is_Task_Body
4360 or else Needs_Sec_Stack_Mark
4361 or else Needs_Custom_Cleanup;
4363 HSS : Node_Id := Handled_Statement_Sequence (N);
4364 Loc : Source_Ptr;
4365 Cln : List_Id;
4367 procedure Wrap_HSS_In_Block;
4368 -- Move HSS inside a new block along with the original exception
4369 -- handlers. Make the newly generated block the sole statement of HSS.
4371 -----------------------
4372 -- Wrap_HSS_In_Block --
4373 -----------------------
4375 procedure Wrap_HSS_In_Block is
4376 Block : Node_Id;
4377 Block_Id : Entity_Id;
4378 End_Lab : Node_Id;
4380 begin
4381 -- Preserve end label to provide proper cross-reference information
4383 End_Lab := End_Label (HSS);
4384 Block :=
4385 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
4387 Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4388 Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
4389 Set_Etype (Block_Id, Standard_Void_Type);
4390 Set_Block_Node (Block_Id, Identifier (Block));
4392 -- Signal the finalization machinery that this particular block
4393 -- contains the original context.
4395 Set_Is_Finalization_Wrapper (Block);
4397 Set_Handled_Statement_Sequence (N,
4398 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
4399 HSS := Handled_Statement_Sequence (N);
4401 Set_First_Real_Statement (HSS, Block);
4402 Set_End_Label (HSS, End_Lab);
4404 -- Comment needed here, see RH for 1.306 ???
4406 if Nkind (N) = N_Subprogram_Body then
4407 Set_Has_Nested_Block_With_Handler (Scop);
4408 end if;
4409 end Wrap_HSS_In_Block;
4411 -- Start of processing for Expand_Cleanup_Actions
4413 begin
4414 -- The current construct does not need any form of servicing
4416 if not Actions_Required then
4417 return;
4419 -- If the current node is a rewritten task body and the descriptors have
4420 -- not been delayed (due to some nested instantiations), do not generate
4421 -- redundant cleanup actions.
4423 elsif Is_Task_Body
4424 and then Nkind (N) = N_Subprogram_Body
4425 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
4426 then
4427 return;
4428 end if;
4430 -- If an extended return statement contains something like
4432 -- X := F (...);
4434 -- where F is a build-in-place function call returning a controlled
4435 -- type, then a temporary object will be implicitly declared as part
4436 -- of the statement list, and this will need cleanup. In such cases,
4437 -- we transform:
4439 -- return Result : T := ... do
4440 -- <statements> -- possibly with handlers
4441 -- end return;
4443 -- into:
4445 -- return Result : T := ... do
4446 -- declare -- no declarations
4447 -- begin
4448 -- <statements> -- possibly with handlers
4449 -- end; -- no handlers
4450 -- end return;
4452 -- So Expand_Cleanup_Actions will end up being called recursively on the
4453 -- block statement.
4455 if Nkind (N) = N_Extended_Return_Statement then
4456 declare
4457 Block : constant Node_Id :=
4458 Make_Block_Statement (Sloc (N),
4459 Declarations => Empty_List,
4460 Handled_Statement_Sequence =>
4461 Handled_Statement_Sequence (N));
4462 begin
4463 Set_Handled_Statement_Sequence (N,
4464 Make_Handled_Sequence_Of_Statements (Sloc (N),
4465 Statements => New_List (Block)));
4467 Analyze (Block);
4468 end;
4470 -- Analysis of the block did all the work
4472 return;
4473 end if;
4475 if Needs_Custom_Cleanup then
4476 Cln := Cleanup_Actions (N);
4477 else
4478 Cln := No_List;
4479 end if;
4481 declare
4482 Decls : List_Id := Declarations (N);
4483 Fin_Id : Entity_Id;
4484 Mark : Entity_Id := Empty;
4485 New_Decls : List_Id;
4486 Old_Poll : Boolean;
4488 begin
4489 -- If we are generating expanded code for debugging purposes, use the
4490 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4491 -- be updated subsequently to reference the proper line in .dg files.
4492 -- If we are not debugging generated code, use No_Location instead,
4493 -- so that no debug information is generated for the cleanup code.
4494 -- This makes the behavior of the NEXT command in GDB monotonic, and
4495 -- makes the placement of breakpoints more accurate.
4497 if Debug_Generated_Code then
4498 Loc := Sloc (Scop);
4499 else
4500 Loc := No_Location;
4501 end if;
4503 -- Set polling off. The finalization and cleanup code is executed
4504 -- with aborts deferred.
4506 Old_Poll := Polling_Required;
4507 Polling_Required := False;
4509 -- A task activation call has already been built for a task
4510 -- allocation block.
4512 if not Is_Task_Allocation then
4513 Build_Task_Activation_Call (N);
4514 end if;
4516 if Is_Master then
4517 Establish_Task_Master (N);
4518 end if;
4520 New_Decls := New_List;
4522 -- If secondary stack is in use, generate:
4524 -- Mnn : constant Mark_Id := SS_Mark;
4526 if Needs_Sec_Stack_Mark then
4527 Mark := Make_Temporary (Loc, 'M');
4529 Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
4530 Set_Uses_Sec_Stack (Scop, False);
4531 end if;
4533 -- If exception handlers are present, wrap the sequence of statements
4534 -- in a block since it is not possible to have exception handlers and
4535 -- an At_End handler in the same construct.
4537 if Present (Exception_Handlers (HSS)) then
4538 Wrap_HSS_In_Block;
4540 -- Ensure that the First_Real_Statement field is set
4542 elsif No (First_Real_Statement (HSS)) then
4543 Set_First_Real_Statement (HSS, First (Statements (HSS)));
4544 end if;
4546 -- Do not move the Activation_Chain declaration in the context of
4547 -- task allocation blocks. Task allocation blocks use _chain in their
4548 -- cleanup handlers and gigi complains if it is declared in the
4549 -- sequence of statements of the scope that declares the handler.
4551 if Is_Task_Allocation then
4552 declare
4553 Chain : constant Entity_Id := Activation_Chain_Entity (N);
4554 Decl : Node_Id;
4556 begin
4557 Decl := First (Decls);
4558 while Nkind (Decl) /= N_Object_Declaration
4559 or else Defining_Identifier (Decl) /= Chain
4560 loop
4561 Next (Decl);
4563 -- A task allocation block should always include a _chain
4564 -- declaration.
4566 pragma Assert (Present (Decl));
4567 end loop;
4569 Remove (Decl);
4570 Prepend_To (New_Decls, Decl);
4571 end;
4572 end if;
4574 -- Ensure the presence of a declaration list in order to successfully
4575 -- append all original statements to it.
4577 if No (Decls) then
4578 Set_Declarations (N, New_List);
4579 Decls := Declarations (N);
4580 end if;
4582 -- Move the declarations into the sequence of statements in order to
4583 -- have them protected by the At_End handler. It may seem weird to
4584 -- put declarations in the sequence of statement but in fact nothing
4585 -- forbids that at the tree level.
4587 Append_List_To (Decls, Statements (HSS));
4588 Set_Statements (HSS, Decls);
4590 -- Reset the Sloc of the handled statement sequence to properly
4591 -- reflect the new initial "statement" in the sequence.
4593 Set_Sloc (HSS, Sloc (First (Decls)));
4595 -- The declarations of finalizer spec and auxiliary variables replace
4596 -- the old declarations that have been moved inward.
4598 Set_Declarations (N, New_Decls);
4599 Analyze_Declarations (New_Decls);
4601 -- Generate finalization calls for all controlled objects appearing
4602 -- in the statements of N. Add context specific cleanup for various
4603 -- constructs.
4605 Build_Finalizer
4606 (N => N,
4607 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
4608 Mark_Id => Mark,
4609 Top_Decls => New_Decls,
4610 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
4611 or else Is_Master,
4612 Fin_Id => Fin_Id);
4614 if Present (Fin_Id) then
4615 Build_Finalizer_Call (N, Fin_Id);
4616 end if;
4618 -- Restore saved polling mode
4620 Polling_Required := Old_Poll;
4621 end;
4622 end Expand_Cleanup_Actions;
4624 ---------------------------
4625 -- Expand_N_Package_Body --
4626 ---------------------------
4628 -- Add call to Activate_Tasks if body is an activator (actual processing
4629 -- is in chapter 9).
4631 -- Generate subprogram descriptor for elaboration routine
4633 -- Encode entity names in package body
4635 procedure Expand_N_Package_Body (N : Node_Id) is
4636 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
4637 Fin_Id : Entity_Id;
4639 begin
4640 -- This is done only for non-generic packages
4642 if Ekind (Spec_Id) = E_Package then
4643 Push_Scope (Spec_Id);
4645 -- Build dispatch tables of library level tagged types
4647 if Tagged_Type_Expansion
4648 and then Is_Library_Level_Entity (Spec_Id)
4649 then
4650 Build_Static_Dispatch_Tables (N);
4651 end if;
4653 Build_Task_Activation_Call (N);
4655 -- Verify the run-time semantics of pragma Initial_Condition at the
4656 -- end of the body statements.
4658 Expand_Pragma_Initial_Condition (Spec_Id, N);
4660 Pop_Scope;
4661 end if;
4663 Set_Elaboration_Flag (N, Spec_Id);
4664 Set_In_Package_Body (Spec_Id, False);
4666 -- Set to encode entity names in package body before gigi is called
4668 Qualify_Entity_Names (N);
4670 if Ekind (Spec_Id) /= E_Generic_Package then
4671 Build_Finalizer
4672 (N => N,
4673 Clean_Stmts => No_List,
4674 Mark_Id => Empty,
4675 Top_Decls => No_List,
4676 Defer_Abort => False,
4677 Fin_Id => Fin_Id);
4679 if Present (Fin_Id) then
4680 declare
4681 Body_Ent : Node_Id := Defining_Unit_Name (N);
4683 begin
4684 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
4685 Body_Ent := Defining_Identifier (Body_Ent);
4686 end if;
4688 Set_Finalizer (Body_Ent, Fin_Id);
4689 end;
4690 end if;
4691 end if;
4692 end Expand_N_Package_Body;
4694 ----------------------------------
4695 -- Expand_N_Package_Declaration --
4696 ----------------------------------
4698 -- Add call to Activate_Tasks if there are tasks declared and the package
4699 -- has no body. Note that in Ada 83 this may result in premature activation
4700 -- of some tasks, given that we cannot tell whether a body will eventually
4701 -- appear.
4703 procedure Expand_N_Package_Declaration (N : Node_Id) is
4704 Id : constant Entity_Id := Defining_Entity (N);
4705 Spec : constant Node_Id := Specification (N);
4706 Decls : List_Id;
4707 Fin_Id : Entity_Id;
4709 No_Body : Boolean := False;
4710 -- True in the case of a package declaration that is a compilation
4711 -- unit and for which no associated body will be compiled in this
4712 -- compilation.
4714 begin
4715 -- Case of a package declaration other than a compilation unit
4717 if Nkind (Parent (N)) /= N_Compilation_Unit then
4718 null;
4720 -- Case of a compilation unit that does not require a body
4722 elsif not Body_Required (Parent (N))
4723 and then not Unit_Requires_Body (Id)
4724 then
4725 No_Body := True;
4727 -- Special case of generating calling stubs for a remote call interface
4728 -- package: even though the package declaration requires one, the body
4729 -- won't be processed in this compilation (so any stubs for RACWs
4730 -- declared in the package must be generated here, along with the spec).
4732 elsif Parent (N) = Cunit (Main_Unit)
4733 and then Is_Remote_Call_Interface (Id)
4734 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
4735 then
4736 No_Body := True;
4737 end if;
4739 -- For a nested instance, delay processing until freeze point
4741 if Has_Delayed_Freeze (Id)
4742 and then Nkind (Parent (N)) /= N_Compilation_Unit
4743 then
4744 return;
4745 end if;
4747 -- For a package declaration that implies no associated body, generate
4748 -- task activation call and RACW supporting bodies now (since we won't
4749 -- have a specific separate compilation unit for that).
4751 if No_Body then
4752 Push_Scope (Id);
4754 -- Generate RACW subprogram bodies
4756 if Has_RACW (Id) then
4757 Decls := Private_Declarations (Spec);
4759 if No (Decls) then
4760 Decls := Visible_Declarations (Spec);
4761 end if;
4763 if No (Decls) then
4764 Decls := New_List;
4765 Set_Visible_Declarations (Spec, Decls);
4766 end if;
4768 Append_RACW_Bodies (Decls, Id);
4769 Analyze_List (Decls);
4770 end if;
4772 -- Generate task activation call as last step of elaboration
4774 if Present (Activation_Chain_Entity (N)) then
4775 Build_Task_Activation_Call (N);
4776 end if;
4778 -- Verify the run-time semantics of pragma Initial_Condition at the
4779 -- end of the private declarations when the package lacks a body.
4781 Expand_Pragma_Initial_Condition (Id, N);
4783 Pop_Scope;
4784 end if;
4786 -- Build dispatch tables of library level tagged types
4788 if Tagged_Type_Expansion
4789 and then (Is_Compilation_Unit (Id)
4790 or else (Is_Generic_Instance (Id)
4791 and then Is_Library_Level_Entity (Id)))
4792 then
4793 Build_Static_Dispatch_Tables (N);
4794 end if;
4796 -- Note: it is not necessary to worry about generating a subprogram
4797 -- descriptor, since the only way to get exception handlers into a
4798 -- package spec is to include instantiations, and that would cause
4799 -- generation of subprogram descriptors to be delayed in any case.
4801 -- Set to encode entity names in package spec before gigi is called
4803 Qualify_Entity_Names (N);
4805 if Ekind (Id) /= E_Generic_Package then
4806 Build_Finalizer
4807 (N => N,
4808 Clean_Stmts => No_List,
4809 Mark_Id => Empty,
4810 Top_Decls => No_List,
4811 Defer_Abort => False,
4812 Fin_Id => Fin_Id);
4814 Set_Finalizer (Id, Fin_Id);
4815 end if;
4816 end Expand_N_Package_Declaration;
4818 -----------------------------
4819 -- Find_Node_To_Be_Wrapped --
4820 -----------------------------
4822 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
4823 Curr : Node_Id;
4824 Prev : Node_Id;
4826 begin
4827 Curr := N;
4828 Prev := Empty;
4829 loop
4830 case Nkind (Curr) is
4832 -- Declarations
4834 -- Declarations act as a boundary for a transient scope even if
4835 -- they are not wrapped, see Wrap_Transient_Declaration.
4837 when N_Object_Declaration
4838 | N_Object_Renaming_Declaration
4839 | N_Subtype_Declaration
4841 return Curr;
4843 -- Statements
4845 -- Statements and statement-like constructs act as a boundary for
4846 -- a transient scope.
4848 when N_Accept_Alternative
4849 | N_Attribute_Definition_Clause
4850 | N_Case_Statement
4851 | N_Case_Statement_Alternative
4852 | N_Code_Statement
4853 | N_Delay_Alternative
4854 | N_Delay_Until_Statement
4855 | N_Delay_Relative_Statement
4856 | N_Discriminant_Association
4857 | N_Elsif_Part
4858 | N_Entry_Body_Formal_Part
4859 | N_Exit_Statement
4860 | N_If_Statement
4861 | N_Iteration_Scheme
4862 | N_Terminate_Alternative
4864 pragma Assert (Present (Prev));
4865 return Prev;
4867 -- Assignment statements are usually wrapped in a transient block
4868 -- except when they are generated as part of controlled aggregate
4869 -- where the wrapping should take place more globally. Note that
4870 -- No_Ctrl_Actions is set also for non-controlled assignments, in
4871 -- order to disable the use of dispatching _assign, thus the test
4872 -- for a controlled type.
4874 when N_Assignment_Statement =>
4875 if No_Ctrl_Actions (Curr)
4876 and then Needs_Finalization (Etype (Name (Curr)))
4877 then
4878 return Empty;
4879 else
4880 return Curr;
4881 end if;
4883 -- An entry of procedure call is usually wrapped except when it
4884 -- acts as the alternative of a conditional or timed entry call.
4885 -- In that case wrap the context of the alternative.
4887 when N_Entry_Call_Statement
4888 | N_Procedure_Call_Statement
4890 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
4891 and then Nkind_In (Parent (Parent (Curr)),
4892 N_Conditional_Entry_Call,
4893 N_Timed_Entry_Call)
4894 then
4895 return Parent (Parent (Curr));
4896 else
4897 return Curr;
4898 end if;
4900 when N_Pragma
4901 | N_Raise_Statement
4903 return Curr;
4905 -- A return statement is not wrapped when the associated function
4906 -- would require wrapping.
4908 when N_Simple_Return_Statement =>
4909 if Requires_Transient_Scope (Etype
4910 (Return_Applies_To (Return_Statement_Entity (Curr))))
4911 then
4912 return Empty;
4913 else
4914 return Curr;
4915 end if;
4917 -- Special
4919 when N_Attribute_Reference =>
4920 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
4921 return Curr;
4922 end if;
4924 -- If the construct is within the iteration scheme of a loop, it
4925 -- requires a declaration followed by an assignment, in order to
4926 -- have a usable statement to wrap.
4928 when N_Loop_Parameter_Specification =>
4929 return Parent (Curr);
4931 -- Termination
4933 -- The following nodes represent "dummy contexts" which do not
4934 -- need to be wrapped.
4936 when N_Component_Declaration
4937 | N_Discriminant_Specification
4938 | N_Parameter_Specification
4940 return Empty;
4942 -- If the traversal leaves a scope without having been able to
4943 -- find a construct to wrap, something is going wrong, but this
4944 -- can happen in error situations that are not detected yet (such
4945 -- as a dynamic string in a pragma Export).
4947 when N_Block_Statement
4948 | N_Entry_Body
4949 | N_Package_Body
4950 | N_Package_Declaration
4951 | N_Protected_Body
4952 | N_Subprogram_Body
4953 | N_Task_Body
4955 return Empty;
4957 -- Default
4959 when others =>
4960 null;
4961 end case;
4963 Prev := Curr;
4964 Curr := Parent (Curr);
4965 end loop;
4966 end Find_Node_To_Be_Wrapped;
4968 ----------------------------------
4969 -- Has_New_Controlled_Component --
4970 ----------------------------------
4972 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
4973 Comp : Entity_Id;
4975 begin
4976 if not Is_Tagged_Type (E) then
4977 return Has_Controlled_Component (E);
4978 elsif not Is_Derived_Type (E) then
4979 return Has_Controlled_Component (E);
4980 end if;
4982 Comp := First_Component (E);
4983 while Present (Comp) loop
4984 if Chars (Comp) = Name_uParent then
4985 null;
4987 elsif Scope (Original_Record_Component (Comp)) = E
4988 and then Needs_Finalization (Etype (Comp))
4989 then
4990 return True;
4991 end if;
4993 Next_Component (Comp);
4994 end loop;
4996 return False;
4997 end Has_New_Controlled_Component;
4999 ---------------------------------
5000 -- Has_Simple_Protected_Object --
5001 ---------------------------------
5003 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
5004 begin
5005 if Has_Task (T) then
5006 return False;
5008 elsif Is_Simple_Protected_Type (T) then
5009 return True;
5011 elsif Is_Array_Type (T) then
5012 return Has_Simple_Protected_Object (Component_Type (T));
5014 elsif Is_Record_Type (T) then
5015 declare
5016 Comp : Entity_Id;
5018 begin
5019 Comp := First_Component (T);
5020 while Present (Comp) loop
5021 if Has_Simple_Protected_Object (Etype (Comp)) then
5022 return True;
5023 end if;
5025 Next_Component (Comp);
5026 end loop;
5028 return False;
5029 end;
5031 else
5032 return False;
5033 end if;
5034 end Has_Simple_Protected_Object;
5036 ------------------------------------
5037 -- Insert_Actions_In_Scope_Around --
5038 ------------------------------------
5040 procedure Insert_Actions_In_Scope_Around
5041 (N : Node_Id;
5042 Clean : Boolean;
5043 Manage_SS : Boolean)
5045 Act_Before : constant List_Id :=
5046 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
5047 Act_After : constant List_Id :=
5048 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
5049 Act_Cleanup : constant List_Id :=
5050 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
5051 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5052 -- Last), but this was incorrect as Process_Transients_In_Scope may
5053 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5055 procedure Process_Transients_In_Scope
5056 (First_Object : Node_Id;
5057 Last_Object : Node_Id;
5058 Related_Node : Node_Id);
5059 -- Find all transient objects in the list First_Object .. Last_Object
5060 -- and generate finalization actions for them. Related_Node denotes the
5061 -- node which created all transient objects.
5063 ---------------------------------
5064 -- Process_Transients_In_Scope --
5065 ---------------------------------
5067 procedure Process_Transients_In_Scope
5068 (First_Object : Node_Id;
5069 Last_Object : Node_Id;
5070 Related_Node : Node_Id)
5072 Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
5074 Must_Hook : Boolean := False;
5075 -- Flag denoting whether the context requires transient object
5076 -- export to the outer finalizer.
5078 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
5079 -- Determine whether an arbitrary node denotes a subprogram call
5081 procedure Detect_Subprogram_Call is
5082 new Traverse_Proc (Is_Subprogram_Call);
5084 procedure Process_Transient_In_Scope
5085 (Obj_Decl : Node_Id;
5086 Blk_Data : Finalization_Exception_Data;
5087 Blk_Stmts : List_Id);
5088 -- Generate finalization actions for a single transient object
5089 -- denoted by object declaration Obj_Decl. Blk_Data is the
5090 -- exception data of the enclosing block. Blk_Stmts denotes the
5091 -- statements of the enclosing block.
5093 ------------------------
5094 -- Is_Subprogram_Call --
5095 ------------------------
5097 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
5098 begin
5099 -- A regular procedure or function call
5101 if Nkind (N) in N_Subprogram_Call then
5102 Must_Hook := True;
5103 return Abandon;
5105 -- Special cases
5107 -- Heavy expansion may relocate function calls outside the related
5108 -- node. Inspect the original node to detect the initial placement
5109 -- of the call.
5111 elsif Original_Node (N) /= N then
5112 Detect_Subprogram_Call (Original_Node (N));
5114 if Must_Hook then
5115 return Abandon;
5116 else
5117 return OK;
5118 end if;
5120 -- Generalized indexing always involves a function call
5122 elsif Nkind (N) = N_Indexed_Component
5123 and then Present (Generalized_Indexing (N))
5124 then
5125 Must_Hook := True;
5126 return Abandon;
5128 -- Keep searching
5130 else
5131 return OK;
5132 end if;
5133 end Is_Subprogram_Call;
5135 --------------------------------
5136 -- Process_Transient_In_Scope --
5137 --------------------------------
5139 procedure Process_Transient_In_Scope
5140 (Obj_Decl : Node_Id;
5141 Blk_Data : Finalization_Exception_Data;
5142 Blk_Stmts : List_Id)
5144 Loc : constant Source_Ptr := Sloc (Obj_Decl);
5145 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
5146 Fin_Call : Node_Id;
5147 Fin_Stmts : List_Id;
5148 Hook_Assign : Node_Id;
5149 Hook_Clear : Node_Id;
5150 Hook_Decl : Node_Id;
5151 Hook_Insert : Node_Id;
5152 Ptr_Decl : Node_Id;
5154 begin
5155 -- Mark the transient object as successfully processed to avoid
5156 -- double finalization.
5158 Set_Is_Finalized_Transient (Obj_Id);
5160 -- Construct all the pieces necessary to hook and finalize the
5161 -- transient object.
5163 Build_Transient_Object_Statements
5164 (Obj_Decl => Obj_Decl,
5165 Fin_Call => Fin_Call,
5166 Hook_Assign => Hook_Assign,
5167 Hook_Clear => Hook_Clear,
5168 Hook_Decl => Hook_Decl,
5169 Ptr_Decl => Ptr_Decl);
5171 -- The context contains at least one subprogram call which may
5172 -- raise an exception. This scenario employs "hooking" to pass
5173 -- transient objects to the enclosing finalizer in case of an
5174 -- exception.
5176 if Must_Hook then
5178 -- Add the access type which provides a reference to the
5179 -- transient object. Generate:
5181 -- type Ptr_Typ is access all Desig_Typ;
5183 Insert_Action (Obj_Decl, Ptr_Decl);
5185 -- Add the temporary which acts as a hook to the transient
5186 -- object. Generate:
5188 -- Hook : Ptr_Typ := null;
5190 Insert_Action (Obj_Decl, Hook_Decl);
5192 -- When the transient object is initialized by an aggregate,
5193 -- the hook must capture the object after the last aggregate
5194 -- assignment takes place. Only then is the object considered
5195 -- fully initialized. Generate:
5197 -- Hook := Ptr_Typ (Obj_Id);
5198 -- <or>
5199 -- Hook := Obj_Id'Unrestricted_Access;
5201 if Ekind_In (Obj_Id, E_Constant, E_Variable)
5202 and then Present (Last_Aggregate_Assignment (Obj_Id))
5203 then
5204 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
5206 -- Otherwise the hook seizes the related object immediately
5208 else
5209 Hook_Insert := Obj_Decl;
5210 end if;
5212 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
5213 end if;
5215 -- When exception propagation is enabled wrap the hook clear
5216 -- statement and the finalization call into a block to catch
5217 -- potential exceptions raised during finalization. Generate:
5219 -- begin
5220 -- [Hook := null;]
5221 -- [Deep_]Finalize (Obj_Ref);
5223 -- exception
5224 -- when others =>
5225 -- if not Raised then
5226 -- Raised := True;
5227 -- Save_Occurrence
5228 -- (Enn, Get_Current_Excep.all.all);
5229 -- end if;
5230 -- end;
5232 if Exceptions_OK then
5233 Fin_Stmts := New_List;
5235 if Must_Hook then
5236 Append_To (Fin_Stmts, Hook_Clear);
5237 end if;
5239 Append_To (Fin_Stmts, Fin_Call);
5241 Prepend_To (Blk_Stmts,
5242 Make_Block_Statement (Loc,
5243 Handled_Statement_Sequence =>
5244 Make_Handled_Sequence_Of_Statements (Loc,
5245 Statements => Fin_Stmts,
5246 Exception_Handlers => New_List (
5247 Build_Exception_Handler (Blk_Data)))));
5249 -- Otherwise generate:
5251 -- [Hook := null;]
5252 -- [Deep_]Finalize (Obj_Ref);
5254 -- Note that the statements are inserted in reverse order to
5255 -- achieve the desired final order outlined above.
5257 else
5258 Prepend_To (Blk_Stmts, Fin_Call);
5260 if Must_Hook then
5261 Prepend_To (Blk_Stmts, Hook_Clear);
5262 end if;
5263 end if;
5264 end Process_Transient_In_Scope;
5266 -- Local variables
5268 Built : Boolean := False;
5269 Blk_Data : Finalization_Exception_Data;
5270 Blk_Decl : Node_Id := Empty;
5271 Blk_Decls : List_Id := No_List;
5272 Blk_Ins : Node_Id;
5273 Blk_Stmts : List_Id;
5274 Loc : Source_Ptr;
5275 Obj_Decl : Node_Id;
5277 -- Start of processing for Process_Transients_In_Scope
5279 begin
5280 -- The expansion performed by this routine is as follows:
5282 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5283 -- Hook_1 : Ptr_Typ_1 := null;
5284 -- Ctrl_Trans_Obj_1 : ...;
5285 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5286 -- . . .
5287 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5288 -- Hook_N : Ptr_Typ_N := null;
5289 -- Ctrl_Trans_Obj_N : ...;
5290 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5292 -- declare
5293 -- Abrt : constant Boolean := ...;
5294 -- Ex : Exception_Occurrence;
5295 -- Raised : Boolean := False;
5297 -- begin
5298 -- Abort_Defer;
5300 -- begin
5301 -- Hook_N := null;
5302 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5304 -- exception
5305 -- when others =>
5306 -- if not Raised then
5307 -- Raised := True;
5308 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5309 -- end;
5310 -- . . .
5311 -- begin
5312 -- Hook_1 := null;
5313 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5315 -- exception
5316 -- when others =>
5317 -- if not Raised then
5318 -- Raised := True;
5319 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5320 -- end;
5322 -- Abort_Undefer;
5324 -- if Raised and not Abrt then
5325 -- Raise_From_Controlled_Operation (Ex);
5326 -- end if;
5327 -- end;
5329 -- Recognize a scenario where the transient context is an object
5330 -- declaration initialized by a build-in-place function call:
5332 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5334 -- The rough expansion of the above is:
5336 -- Temp : ... := Ctrl_Func_Call;
5337 -- Obj : ...;
5338 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5340 -- The finalization of any transient object must happen after the
5341 -- build-in-place function call is executed.
5343 if Nkind (N) = N_Object_Declaration
5344 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
5345 then
5346 Must_Hook := True;
5347 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
5349 -- Search the context for at least one subprogram call. If found, the
5350 -- machinery exports all transient objects to the enclosing finalizer
5351 -- due to the possibility of abnormal call termination.
5353 else
5354 Detect_Subprogram_Call (N);
5355 Blk_Ins := Last_Object;
5356 end if;
5358 if Clean then
5359 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
5360 end if;
5362 -- Examine all objects in the list First_Object .. Last_Object
5364 Obj_Decl := First_Object;
5365 while Present (Obj_Decl) loop
5366 if Nkind (Obj_Decl) = N_Object_Declaration
5367 and then Analyzed (Obj_Decl)
5368 and then Is_Finalizable_Transient (Obj_Decl, N)
5370 -- Do not process the node to be wrapped since it will be
5371 -- handled by the enclosing finalizer.
5373 and then Obj_Decl /= Related_Node
5374 then
5375 Loc := Sloc (Obj_Decl);
5377 -- Before generating the cleanup code for the first transient
5378 -- object, create a wrapper block which houses all hook clear
5379 -- statements and finalization calls. This wrapper is needed by
5380 -- the back end.
5382 if not Built then
5383 Built := True;
5384 Blk_Stmts := New_List;
5386 -- Generate:
5387 -- Abrt : constant Boolean := ...;
5388 -- Ex : Exception_Occurrence;
5389 -- Raised : Boolean := False;
5391 if Exceptions_OK then
5392 Blk_Decls := New_List;
5393 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
5394 end if;
5396 Blk_Decl :=
5397 Make_Block_Statement (Loc,
5398 Declarations => Blk_Decls,
5399 Handled_Statement_Sequence =>
5400 Make_Handled_Sequence_Of_Statements (Loc,
5401 Statements => Blk_Stmts));
5402 end if;
5404 -- Construct all necessary circuitry to hook and finalize a
5405 -- single transient object.
5407 Process_Transient_In_Scope
5408 (Obj_Decl => Obj_Decl,
5409 Blk_Data => Blk_Data,
5410 Blk_Stmts => Blk_Stmts);
5411 end if;
5413 -- Terminate the scan after the last object has been processed to
5414 -- avoid touching unrelated code.
5416 if Obj_Decl = Last_Object then
5417 exit;
5418 end if;
5420 Next (Obj_Decl);
5421 end loop;
5423 -- Complete the decoration of the enclosing finalization block and
5424 -- insert it into the tree.
5426 if Present (Blk_Decl) then
5428 -- Note that this Abort_Undefer does not require a extra block or
5429 -- an AT_END handler because each finalization exception is caught
5430 -- in its own corresponding finalization block. As a result, the
5431 -- call to Abort_Defer always takes place.
5433 if Abort_Allowed then
5434 Prepend_To (Blk_Stmts,
5435 Build_Runtime_Call (Loc, RE_Abort_Defer));
5437 Append_To (Blk_Stmts,
5438 Build_Runtime_Call (Loc, RE_Abort_Undefer));
5439 end if;
5441 -- Generate:
5442 -- if Raised and then not Abrt then
5443 -- Raise_From_Controlled_Operation (Ex);
5444 -- end if;
5446 if Exceptions_OK then
5447 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
5448 end if;
5450 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
5451 end if;
5452 end Process_Transients_In_Scope;
5454 -- Local variables
5456 Loc : constant Source_Ptr := Sloc (N);
5457 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
5458 First_Obj : Node_Id;
5459 Last_Obj : Node_Id;
5460 Mark_Id : Entity_Id;
5461 Target : Node_Id;
5463 -- Start of processing for Insert_Actions_In_Scope_Around
5465 begin
5466 -- Nothing to do if the scope does not manage the secondary stack or
5467 -- does not contain meaninful actions for insertion.
5469 if not Manage_SS
5470 and then No (Act_Before)
5471 and then No (Act_After)
5472 and then No (Act_Cleanup)
5473 then
5474 return;
5475 end if;
5477 -- If the node to be wrapped is the trigger of an asynchronous select,
5478 -- it is not part of a statement list. The actions must be inserted
5479 -- before the select itself, which is part of some list of statements.
5480 -- Note that the triggering alternative includes the triggering
5481 -- statement and an optional statement list. If the node to be
5482 -- wrapped is part of that list, the normal insertion applies.
5484 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
5485 and then not Is_List_Member (Node_To_Wrap)
5486 then
5487 Target := Parent (Parent (Node_To_Wrap));
5488 else
5489 Target := N;
5490 end if;
5492 First_Obj := Target;
5493 Last_Obj := Target;
5495 -- Add all actions associated with a transient scope into the main tree.
5496 -- There are several scenarios here:
5498 -- +--- Before ----+ +----- After ---+
5499 -- 1) First_Obj ....... Target ........ Last_Obj
5501 -- 2) First_Obj ....... Target
5503 -- 3) Target ........ Last_Obj
5505 -- Flag declarations are inserted before the first object
5507 if Present (Act_Before) then
5508 First_Obj := First (Act_Before);
5509 Insert_List_Before (Target, Act_Before);
5510 end if;
5512 -- Finalization calls are inserted after the last object
5514 if Present (Act_After) then
5515 Last_Obj := Last (Act_After);
5516 Insert_List_After (Target, Act_After);
5517 end if;
5519 -- Mark and release the secondary stack when the context warrants it
5521 if Manage_SS then
5522 Mark_Id := Make_Temporary (Loc, 'M');
5524 -- Generate:
5525 -- Mnn : constant Mark_Id := SS_Mark;
5527 Insert_Before_And_Analyze
5528 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
5530 -- Generate:
5531 -- SS_Release (Mnn);
5533 Insert_After_And_Analyze
5534 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
5535 end if;
5537 -- Check for transient objects associated with Target and generate the
5538 -- appropriate finalization actions for them.
5540 Process_Transients_In_Scope
5541 (First_Object => First_Obj,
5542 Last_Object => Last_Obj,
5543 Related_Node => Target);
5545 -- Reset the action lists
5547 Scope_Stack.Table
5548 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
5549 Scope_Stack.Table
5550 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
5552 if Clean then
5553 Scope_Stack.Table
5554 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
5555 end if;
5556 end Insert_Actions_In_Scope_Around;
5558 ------------------------------
5559 -- Is_Simple_Protected_Type --
5560 ------------------------------
5562 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
5563 begin
5564 return
5565 Is_Protected_Type (T)
5566 and then not Uses_Lock_Free (T)
5567 and then not Has_Entries (T)
5568 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
5569 end Is_Simple_Protected_Type;
5571 -----------------------
5572 -- Make_Adjust_Call --
5573 -----------------------
5575 function Make_Adjust_Call
5576 (Obj_Ref : Node_Id;
5577 Typ : Entity_Id;
5578 Skip_Self : Boolean := False) return Node_Id
5580 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5581 Adj_Id : Entity_Id := Empty;
5582 Ref : Node_Id;
5583 Utyp : Entity_Id;
5585 begin
5586 Ref := Obj_Ref;
5588 -- Recover the proper type which contains Deep_Adjust
5590 if Is_Class_Wide_Type (Typ) then
5591 Utyp := Root_Type (Typ);
5592 else
5593 Utyp := Typ;
5594 end if;
5596 Utyp := Underlying_Type (Base_Type (Utyp));
5597 Set_Assignment_OK (Ref);
5599 -- Deal with untagged derivation of private views
5601 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
5602 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
5603 Ref := Unchecked_Convert_To (Utyp, Ref);
5604 Set_Assignment_OK (Ref);
5605 end if;
5607 -- When dealing with the completion of a private type, use the base
5608 -- type instead.
5610 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
5611 pragma Assert (Is_Private_Type (Typ));
5613 Utyp := Base_Type (Utyp);
5614 Ref := Unchecked_Convert_To (Utyp, Ref);
5615 end if;
5617 -- The underlying type may not be present due to a missing full view. In
5618 -- this case freezing did not take place and there is no [Deep_]Adjust
5619 -- primitive to call.
5621 if No (Utyp) then
5622 return Empty;
5624 elsif Skip_Self then
5625 if Has_Controlled_Component (Utyp) then
5626 if Is_Tagged_Type (Utyp) then
5627 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5628 else
5629 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5630 end if;
5631 end if;
5633 -- Class-wide types, interfaces and types with controlled components
5635 elsif Is_Class_Wide_Type (Typ)
5636 or else Is_Interface (Typ)
5637 or else Has_Controlled_Component (Utyp)
5638 then
5639 if Is_Tagged_Type (Utyp) then
5640 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5641 else
5642 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5643 end if;
5645 -- Derivations from [Limited_]Controlled
5647 elsif Is_Controlled (Utyp) then
5648 if Has_Controlled_Component (Utyp) then
5649 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5650 else
5651 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
5652 end if;
5654 -- Tagged types
5656 elsif Is_Tagged_Type (Utyp) then
5657 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5659 else
5660 raise Program_Error;
5661 end if;
5663 if Present (Adj_Id) then
5665 -- If the object is unanalyzed, set its expected type for use in
5666 -- Convert_View in case an additional conversion is needed.
5668 if No (Etype (Ref))
5669 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
5670 then
5671 Set_Etype (Ref, Typ);
5672 end if;
5674 -- The object reference may need another conversion depending on the
5675 -- type of the formal and that of the actual.
5677 if not Is_Class_Wide_Type (Typ) then
5678 Ref := Convert_View (Adj_Id, Ref);
5679 end if;
5681 return
5682 Make_Call (Loc,
5683 Proc_Id => Adj_Id,
5684 Param => Ref,
5685 Skip_Self => Skip_Self);
5686 else
5687 return Empty;
5688 end if;
5689 end Make_Adjust_Call;
5691 ----------------------
5692 -- Make_Detach_Call --
5693 ----------------------
5695 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
5696 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5698 begin
5699 return
5700 Make_Procedure_Call_Statement (Loc,
5701 Name =>
5702 New_Occurrence_Of (RTE (RE_Detach), Loc),
5703 Parameter_Associations => New_List (
5704 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
5705 end Make_Detach_Call;
5707 ---------------
5708 -- Make_Call --
5709 ---------------
5711 function Make_Call
5712 (Loc : Source_Ptr;
5713 Proc_Id : Entity_Id;
5714 Param : Node_Id;
5715 Skip_Self : Boolean := False) return Node_Id
5717 Params : constant List_Id := New_List (Param);
5719 begin
5720 -- Do not apply the controlled action to the object itself by signaling
5721 -- the related routine to avoid self.
5723 if Skip_Self then
5724 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
5725 end if;
5727 return
5728 Make_Procedure_Call_Statement (Loc,
5729 Name => New_Occurrence_Of (Proc_Id, Loc),
5730 Parameter_Associations => Params);
5731 end Make_Call;
5733 --------------------------
5734 -- Make_Deep_Array_Body --
5735 --------------------------
5737 function Make_Deep_Array_Body
5738 (Prim : Final_Primitives;
5739 Typ : Entity_Id) return List_Id
5741 Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
5743 function Build_Adjust_Or_Finalize_Statements
5744 (Typ : Entity_Id) return List_Id;
5745 -- Create the statements necessary to adjust or finalize an array of
5746 -- controlled elements. Generate:
5748 -- declare
5749 -- Abort : constant Boolean := Triggered_By_Abort;
5750 -- <or>
5751 -- Abort : constant Boolean := False; -- no abort
5753 -- E : Exception_Occurrence;
5754 -- Raised : Boolean := False;
5756 -- begin
5757 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5758 -- ^-- in the finalization case
5759 -- ...
5760 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5761 -- begin
5762 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5764 -- exception
5765 -- when others =>
5766 -- if not Raised then
5767 -- Raised := True;
5768 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5769 -- end if;
5770 -- end;
5771 -- end loop;
5772 -- ...
5773 -- end loop;
5775 -- if Raised and then not Abort then
5776 -- Raise_From_Controlled_Operation (E);
5777 -- end if;
5778 -- end;
5780 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
5781 -- Create the statements necessary to initialize an array of controlled
5782 -- elements. Include a mechanism to carry out partial finalization if an
5783 -- exception occurs. Generate:
5785 -- declare
5786 -- Counter : Integer := 0;
5788 -- begin
5789 -- for J1 in V'Range (1) loop
5790 -- ...
5791 -- for JN in V'Range (N) loop
5792 -- begin
5793 -- [Deep_]Initialize (V (J1, ..., JN));
5795 -- Counter := Counter + 1;
5797 -- exception
5798 -- when others =>
5799 -- declare
5800 -- Abort : constant Boolean := Triggered_By_Abort;
5801 -- <or>
5802 -- Abort : constant Boolean := False; -- no abort
5803 -- E : Exception_Occurrence;
5804 -- Raised : Boolean := False;
5806 -- begin
5807 -- Counter :=
5808 -- V'Length (1) *
5809 -- V'Length (2) *
5810 -- ...
5811 -- V'Length (N) - Counter;
5813 -- for F1 in reverse V'Range (1) loop
5814 -- ...
5815 -- for FN in reverse V'Range (N) loop
5816 -- if Counter > 0 then
5817 -- Counter := Counter - 1;
5818 -- else
5819 -- begin
5820 -- [Deep_]Finalize (V (F1, ..., FN));
5822 -- exception
5823 -- when others =>
5824 -- if not Raised then
5825 -- Raised := True;
5826 -- Save_Occurrence (E,
5827 -- Get_Current_Excep.all.all);
5828 -- end if;
5829 -- end;
5830 -- end if;
5831 -- end loop;
5832 -- ...
5833 -- end loop;
5834 -- end;
5836 -- if Raised and then not Abort then
5837 -- Raise_From_Controlled_Operation (E);
5838 -- end if;
5840 -- raise;
5841 -- end;
5842 -- end loop;
5843 -- end loop;
5844 -- end;
5846 function New_References_To
5847 (L : List_Id;
5848 Loc : Source_Ptr) return List_Id;
5849 -- Given a list of defining identifiers, return a list of references to
5850 -- the original identifiers, in the same order as they appear.
5852 -----------------------------------------
5853 -- Build_Adjust_Or_Finalize_Statements --
5854 -----------------------------------------
5856 function Build_Adjust_Or_Finalize_Statements
5857 (Typ : Entity_Id) return List_Id
5859 Comp_Typ : constant Entity_Id := Component_Type (Typ);
5860 Index_List : constant List_Id := New_List;
5861 Loc : constant Source_Ptr := Sloc (Typ);
5862 Num_Dims : constant Int := Number_Dimensions (Typ);
5864 procedure Build_Indexes;
5865 -- Generate the indexes used in the dimension loops
5867 -------------------
5868 -- Build_Indexes --
5869 -------------------
5871 procedure Build_Indexes is
5872 begin
5873 -- Generate the following identifiers:
5874 -- Jnn - for initialization
5876 for Dim in 1 .. Num_Dims loop
5877 Append_To (Index_List,
5878 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
5879 end loop;
5880 end Build_Indexes;
5882 -- Local variables
5884 Final_Decls : List_Id := No_List;
5885 Final_Data : Finalization_Exception_Data;
5886 Block : Node_Id;
5887 Call : Node_Id;
5888 Comp_Ref : Node_Id;
5889 Core_Loop : Node_Id;
5890 Dim : Int;
5891 J : Entity_Id;
5892 Loop_Id : Entity_Id;
5893 Stmts : List_Id;
5895 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5897 begin
5898 Final_Decls := New_List;
5900 Build_Indexes;
5901 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
5903 Comp_Ref :=
5904 Make_Indexed_Component (Loc,
5905 Prefix => Make_Identifier (Loc, Name_V),
5906 Expressions => New_References_To (Index_List, Loc));
5907 Set_Etype (Comp_Ref, Comp_Typ);
5909 -- Generate:
5910 -- [Deep_]Adjust (V (J1, ..., JN))
5912 if Prim = Adjust_Case then
5913 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5915 -- Generate:
5916 -- [Deep_]Finalize (V (J1, ..., JN))
5918 else pragma Assert (Prim = Finalize_Case);
5919 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
5920 end if;
5922 if Present (Call) then
5924 -- Generate the block which houses the adjust or finalize call:
5926 -- begin
5927 -- <adjust or finalize call>
5929 -- exception
5930 -- when others =>
5931 -- if not Raised then
5932 -- Raised := True;
5933 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5934 -- end if;
5935 -- end;
5937 if Exceptions_OK then
5938 Core_Loop :=
5939 Make_Block_Statement (Loc,
5940 Handled_Statement_Sequence =>
5941 Make_Handled_Sequence_Of_Statements (Loc,
5942 Statements => New_List (Call),
5943 Exception_Handlers => New_List (
5944 Build_Exception_Handler (Final_Data))));
5945 else
5946 Core_Loop := Call;
5947 end if;
5949 -- Generate the dimension loops starting from the innermost one
5951 -- for Jnn in [reverse] V'Range (Dim) loop
5952 -- <core loop>
5953 -- end loop;
5955 J := Last (Index_List);
5956 Dim := Num_Dims;
5957 while Present (J) and then Dim > 0 loop
5958 Loop_Id := J;
5959 Prev (J);
5960 Remove (Loop_Id);
5962 Core_Loop :=
5963 Make_Loop_Statement (Loc,
5964 Iteration_Scheme =>
5965 Make_Iteration_Scheme (Loc,
5966 Loop_Parameter_Specification =>
5967 Make_Loop_Parameter_Specification (Loc,
5968 Defining_Identifier => Loop_Id,
5969 Discrete_Subtype_Definition =>
5970 Make_Attribute_Reference (Loc,
5971 Prefix => Make_Identifier (Loc, Name_V),
5972 Attribute_Name => Name_Range,
5973 Expressions => New_List (
5974 Make_Integer_Literal (Loc, Dim))),
5976 Reverse_Present =>
5977 Prim = Finalize_Case)),
5979 Statements => New_List (Core_Loop),
5980 End_Label => Empty);
5982 Dim := Dim - 1;
5983 end loop;
5985 -- Generate the block which contains the core loop, declarations
5986 -- of the abort flag, the exception occurrence, the raised flag
5987 -- and the conditional raise:
5989 -- declare
5990 -- Abort : constant Boolean := Triggered_By_Abort;
5991 -- <or>
5992 -- Abort : constant Boolean := False; -- no abort
5994 -- E : Exception_Occurrence;
5995 -- Raised : Boolean := False;
5997 -- begin
5998 -- <core loop>
6000 -- if Raised and then not Abort then
6001 -- Raise_From_Controlled_Operation (E);
6002 -- end if;
6003 -- end;
6005 Stmts := New_List (Core_Loop);
6007 if Exceptions_OK then
6008 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6009 end if;
6011 Block :=
6012 Make_Block_Statement (Loc,
6013 Declarations => Final_Decls,
6014 Handled_Statement_Sequence =>
6015 Make_Handled_Sequence_Of_Statements (Loc,
6016 Statements => Stmts));
6018 -- Otherwise previous errors or a missing full view may prevent the
6019 -- proper freezing of the component type. If this is the case, there
6020 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6022 else
6023 Block := Make_Null_Statement (Loc);
6024 end if;
6026 return New_List (Block);
6027 end Build_Adjust_Or_Finalize_Statements;
6029 ---------------------------------
6030 -- Build_Initialize_Statements --
6031 ---------------------------------
6033 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
6034 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6035 Final_List : constant List_Id := New_List;
6036 Index_List : constant List_Id := New_List;
6037 Loc : constant Source_Ptr := Sloc (Typ);
6038 Num_Dims : constant Int := Number_Dimensions (Typ);
6040 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
6041 -- Generate the following assignment:
6042 -- Counter := V'Length (1) *
6043 -- ...
6044 -- V'Length (N) - Counter;
6046 -- Counter_Id denotes the entity of the counter.
6048 function Build_Finalization_Call return Node_Id;
6049 -- Generate a deep finalization call for an array element
6051 procedure Build_Indexes;
6052 -- Generate the initialization and finalization indexes used in the
6053 -- dimension loops.
6055 function Build_Initialization_Call return Node_Id;
6056 -- Generate a deep initialization call for an array element
6058 ----------------------
6059 -- Build_Assignment --
6060 ----------------------
6062 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
6063 Dim : Int;
6064 Expr : Node_Id;
6066 begin
6067 -- Start from the first dimension and generate:
6068 -- V'Length (1)
6070 Dim := 1;
6071 Expr :=
6072 Make_Attribute_Reference (Loc,
6073 Prefix => Make_Identifier (Loc, Name_V),
6074 Attribute_Name => Name_Length,
6075 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
6077 -- Process the rest of the dimensions, generate:
6078 -- Expr * V'Length (N)
6080 Dim := Dim + 1;
6081 while Dim <= Num_Dims loop
6082 Expr :=
6083 Make_Op_Multiply (Loc,
6084 Left_Opnd => Expr,
6085 Right_Opnd =>
6086 Make_Attribute_Reference (Loc,
6087 Prefix => Make_Identifier (Loc, Name_V),
6088 Attribute_Name => Name_Length,
6089 Expressions => New_List (
6090 Make_Integer_Literal (Loc, Dim))));
6092 Dim := Dim + 1;
6093 end loop;
6095 -- Generate:
6096 -- Counter := Expr - Counter;
6098 return
6099 Make_Assignment_Statement (Loc,
6100 Name => New_Occurrence_Of (Counter_Id, Loc),
6101 Expression =>
6102 Make_Op_Subtract (Loc,
6103 Left_Opnd => Expr,
6104 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
6105 end Build_Assignment;
6107 -----------------------------
6108 -- Build_Finalization_Call --
6109 -----------------------------
6111 function Build_Finalization_Call return Node_Id is
6112 Comp_Ref : constant Node_Id :=
6113 Make_Indexed_Component (Loc,
6114 Prefix => Make_Identifier (Loc, Name_V),
6115 Expressions => New_References_To (Final_List, Loc));
6117 begin
6118 Set_Etype (Comp_Ref, Comp_Typ);
6120 -- Generate:
6121 -- [Deep_]Finalize (V);
6123 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6124 end Build_Finalization_Call;
6126 -------------------
6127 -- Build_Indexes --
6128 -------------------
6130 procedure Build_Indexes is
6131 begin
6132 -- Generate the following identifiers:
6133 -- Jnn - for initialization
6134 -- Fnn - for finalization
6136 for Dim in 1 .. Num_Dims loop
6137 Append_To (Index_List,
6138 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6140 Append_To (Final_List,
6141 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
6142 end loop;
6143 end Build_Indexes;
6145 -------------------------------
6146 -- Build_Initialization_Call --
6147 -------------------------------
6149 function Build_Initialization_Call return Node_Id is
6150 Comp_Ref : constant Node_Id :=
6151 Make_Indexed_Component (Loc,
6152 Prefix => Make_Identifier (Loc, Name_V),
6153 Expressions => New_References_To (Index_List, Loc));
6155 begin
6156 Set_Etype (Comp_Ref, Comp_Typ);
6158 -- Generate:
6159 -- [Deep_]Initialize (V (J1, ..., JN));
6161 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6162 end Build_Initialization_Call;
6164 -- Local variables
6166 Counter_Id : Entity_Id;
6167 Dim : Int;
6168 F : Node_Id;
6169 Fin_Stmt : Node_Id;
6170 Final_Block : Node_Id;
6171 Final_Data : Finalization_Exception_Data;
6172 Final_Decls : List_Id := No_List;
6173 Final_Loop : Node_Id;
6174 Init_Block : Node_Id;
6175 Init_Call : Node_Id;
6176 Init_Loop : Node_Id;
6177 J : Node_Id;
6178 Loop_Id : Node_Id;
6179 Stmts : List_Id;
6181 -- Start of processing for Build_Initialize_Statements
6183 begin
6184 Counter_Id := Make_Temporary (Loc, 'C');
6185 Final_Decls := New_List;
6187 Build_Indexes;
6188 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6190 -- Generate the block which houses the finalization call, the index
6191 -- guard and the handler which triggers Program_Error later on.
6193 -- if Counter > 0 then
6194 -- Counter := Counter - 1;
6195 -- else
6196 -- begin
6197 -- [Deep_]Finalize (V (F1, ..., FN));
6198 -- exception
6199 -- when others =>
6200 -- if not Raised then
6201 -- Raised := True;
6202 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6203 -- end if;
6204 -- end;
6205 -- end if;
6207 Fin_Stmt := Build_Finalization_Call;
6209 if Present (Fin_Stmt) then
6210 if Exceptions_OK then
6211 Fin_Stmt :=
6212 Make_Block_Statement (Loc,
6213 Handled_Statement_Sequence =>
6214 Make_Handled_Sequence_Of_Statements (Loc,
6215 Statements => New_List (Fin_Stmt),
6216 Exception_Handlers => New_List (
6217 Build_Exception_Handler (Final_Data))));
6218 end if;
6220 -- This is the core of the loop, the dimension iterators are added
6221 -- one by one in reverse.
6223 Final_Loop :=
6224 Make_If_Statement (Loc,
6225 Condition =>
6226 Make_Op_Gt (Loc,
6227 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6228 Right_Opnd => Make_Integer_Literal (Loc, 0)),
6230 Then_Statements => New_List (
6231 Make_Assignment_Statement (Loc,
6232 Name => New_Occurrence_Of (Counter_Id, Loc),
6233 Expression =>
6234 Make_Op_Subtract (Loc,
6235 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6236 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
6238 Else_Statements => New_List (Fin_Stmt));
6240 -- Generate all finalization loops starting from the innermost
6241 -- dimension.
6243 -- for Fnn in reverse V'Range (Dim) loop
6244 -- <final loop>
6245 -- end loop;
6247 F := Last (Final_List);
6248 Dim := Num_Dims;
6249 while Present (F) and then Dim > 0 loop
6250 Loop_Id := F;
6251 Prev (F);
6252 Remove (Loop_Id);
6254 Final_Loop :=
6255 Make_Loop_Statement (Loc,
6256 Iteration_Scheme =>
6257 Make_Iteration_Scheme (Loc,
6258 Loop_Parameter_Specification =>
6259 Make_Loop_Parameter_Specification (Loc,
6260 Defining_Identifier => Loop_Id,
6261 Discrete_Subtype_Definition =>
6262 Make_Attribute_Reference (Loc,
6263 Prefix => Make_Identifier (Loc, Name_V),
6264 Attribute_Name => Name_Range,
6265 Expressions => New_List (
6266 Make_Integer_Literal (Loc, Dim))),
6268 Reverse_Present => True)),
6270 Statements => New_List (Final_Loop),
6271 End_Label => Empty);
6273 Dim := Dim - 1;
6274 end loop;
6276 -- Generate the block which contains the finalization loops, the
6277 -- declarations of the abort flag, the exception occurrence, the
6278 -- raised flag and the conditional raise.
6280 -- declare
6281 -- Abort : constant Boolean := Triggered_By_Abort;
6282 -- <or>
6283 -- Abort : constant Boolean := False; -- no abort
6285 -- E : Exception_Occurrence;
6286 -- Raised : Boolean := False;
6288 -- begin
6289 -- Counter :=
6290 -- V'Length (1) *
6291 -- ...
6292 -- V'Length (N) - Counter;
6294 -- <final loop>
6296 -- if Raised and then not Abort then
6297 -- Raise_From_Controlled_Operation (E);
6298 -- end if;
6300 -- raise;
6301 -- end;
6303 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
6305 if Exceptions_OK then
6306 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6307 Append_To (Stmts, Make_Raise_Statement (Loc));
6308 end if;
6310 Final_Block :=
6311 Make_Block_Statement (Loc,
6312 Declarations => Final_Decls,
6313 Handled_Statement_Sequence =>
6314 Make_Handled_Sequence_Of_Statements (Loc,
6315 Statements => Stmts));
6317 -- Otherwise previous errors or a missing full view may prevent the
6318 -- proper freezing of the component type. If this is the case, there
6319 -- is no [Deep_]Finalize primitive to call.
6321 else
6322 Final_Block := Make_Null_Statement (Loc);
6323 end if;
6325 -- Generate the block which contains the initialization call and
6326 -- the partial finalization code.
6328 -- begin
6329 -- [Deep_]Initialize (V (J1, ..., JN));
6331 -- Counter := Counter + 1;
6333 -- exception
6334 -- when others =>
6335 -- <finalization code>
6336 -- end;
6338 Init_Call := Build_Initialization_Call;
6340 -- Only create finalization block if there is a non-trivial
6341 -- call to initialization.
6343 if Present (Init_Call)
6344 and then Nkind (Init_Call) /= N_Null_Statement
6345 then
6346 Init_Loop :=
6347 Make_Block_Statement (Loc,
6348 Handled_Statement_Sequence =>
6349 Make_Handled_Sequence_Of_Statements (Loc,
6350 Statements => New_List (Init_Call),
6351 Exception_Handlers => New_List (
6352 Make_Exception_Handler (Loc,
6353 Exception_Choices => New_List (
6354 Make_Others_Choice (Loc)),
6355 Statements => New_List (Final_Block)))));
6357 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
6358 Make_Assignment_Statement (Loc,
6359 Name => New_Occurrence_Of (Counter_Id, Loc),
6360 Expression =>
6361 Make_Op_Add (Loc,
6362 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6363 Right_Opnd => Make_Integer_Literal (Loc, 1))));
6365 -- Generate all initialization loops starting from the innermost
6366 -- dimension.
6368 -- for Jnn in V'Range (Dim) loop
6369 -- <init loop>
6370 -- end loop;
6372 J := Last (Index_List);
6373 Dim := Num_Dims;
6374 while Present (J) and then Dim > 0 loop
6375 Loop_Id := J;
6376 Prev (J);
6377 Remove (Loop_Id);
6379 Init_Loop :=
6380 Make_Loop_Statement (Loc,
6381 Iteration_Scheme =>
6382 Make_Iteration_Scheme (Loc,
6383 Loop_Parameter_Specification =>
6384 Make_Loop_Parameter_Specification (Loc,
6385 Defining_Identifier => Loop_Id,
6386 Discrete_Subtype_Definition =>
6387 Make_Attribute_Reference (Loc,
6388 Prefix => Make_Identifier (Loc, Name_V),
6389 Attribute_Name => Name_Range,
6390 Expressions => New_List (
6391 Make_Integer_Literal (Loc, Dim))))),
6393 Statements => New_List (Init_Loop),
6394 End_Label => Empty);
6396 Dim := Dim - 1;
6397 end loop;
6399 -- Generate the block which contains the counter variable and the
6400 -- initialization loops.
6402 -- declare
6403 -- Counter : Integer := 0;
6404 -- begin
6405 -- <init loop>
6406 -- end;
6408 Init_Block :=
6409 Make_Block_Statement (Loc,
6410 Declarations => New_List (
6411 Make_Object_Declaration (Loc,
6412 Defining_Identifier => Counter_Id,
6413 Object_Definition =>
6414 New_Occurrence_Of (Standard_Integer, Loc),
6415 Expression => Make_Integer_Literal (Loc, 0))),
6417 Handled_Statement_Sequence =>
6418 Make_Handled_Sequence_Of_Statements (Loc,
6419 Statements => New_List (Init_Loop)));
6421 -- Otherwise previous errors or a missing full view may prevent the
6422 -- proper freezing of the component type. If this is the case, there
6423 -- is no [Deep_]Initialize primitive to call.
6425 else
6426 Init_Block := Make_Null_Statement (Loc);
6427 end if;
6429 return New_List (Init_Block);
6430 end Build_Initialize_Statements;
6432 -----------------------
6433 -- New_References_To --
6434 -----------------------
6436 function New_References_To
6437 (L : List_Id;
6438 Loc : Source_Ptr) return List_Id
6440 Refs : constant List_Id := New_List;
6441 Id : Node_Id;
6443 begin
6444 Id := First (L);
6445 while Present (Id) loop
6446 Append_To (Refs, New_Occurrence_Of (Id, Loc));
6447 Next (Id);
6448 end loop;
6450 return Refs;
6451 end New_References_To;
6453 -- Start of processing for Make_Deep_Array_Body
6455 begin
6456 case Prim is
6457 when Address_Case =>
6458 return Make_Finalize_Address_Stmts (Typ);
6460 when Adjust_Case
6461 | Finalize_Case
6463 return Build_Adjust_Or_Finalize_Statements (Typ);
6465 when Initialize_Case =>
6466 return Build_Initialize_Statements (Typ);
6467 end case;
6468 end Make_Deep_Array_Body;
6470 --------------------
6471 -- Make_Deep_Proc --
6472 --------------------
6474 function Make_Deep_Proc
6475 (Prim : Final_Primitives;
6476 Typ : Entity_Id;
6477 Stmts : List_Id) return Entity_Id
6479 Loc : constant Source_Ptr := Sloc (Typ);
6480 Formals : List_Id;
6481 Proc_Id : Entity_Id;
6483 begin
6484 -- Create the object formal, generate:
6485 -- V : System.Address
6487 if Prim = Address_Case then
6488 Formals := New_List (
6489 Make_Parameter_Specification (Loc,
6490 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6491 Parameter_Type =>
6492 New_Occurrence_Of (RTE (RE_Address), Loc)));
6494 -- Default case
6496 else
6497 -- V : in out Typ
6499 Formals := New_List (
6500 Make_Parameter_Specification (Loc,
6501 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6502 In_Present => True,
6503 Out_Present => True,
6504 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
6506 -- F : Boolean := True
6508 if Prim = Adjust_Case
6509 or else Prim = Finalize_Case
6510 then
6511 Append_To (Formals,
6512 Make_Parameter_Specification (Loc,
6513 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
6514 Parameter_Type =>
6515 New_Occurrence_Of (Standard_Boolean, Loc),
6516 Expression =>
6517 New_Occurrence_Of (Standard_True, Loc)));
6518 end if;
6519 end if;
6521 Proc_Id :=
6522 Make_Defining_Identifier (Loc,
6523 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
6525 -- Generate:
6526 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6527 -- begin
6528 -- <stmts>
6529 -- exception -- Finalize and Adjust cases only
6530 -- raise Program_Error;
6531 -- end Deep_Initialize / Adjust / Finalize;
6533 -- or
6535 -- procedure Finalize_Address (V : System.Address) is
6536 -- begin
6537 -- <stmts>
6538 -- end Finalize_Address;
6540 Discard_Node (
6541 Make_Subprogram_Body (Loc,
6542 Specification =>
6543 Make_Procedure_Specification (Loc,
6544 Defining_Unit_Name => Proc_Id,
6545 Parameter_Specifications => Formals),
6547 Declarations => Empty_List,
6549 Handled_Statement_Sequence =>
6550 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
6552 -- If there are no calls to component initialization, indicate that
6553 -- the procedure is trivial, so prevent calls to it.
6555 if Is_Empty_List (Stmts)
6556 or else Nkind (First (Stmts)) = N_Null_Statement
6557 then
6558 Set_Is_Trivial_Subprogram (Proc_Id);
6559 end if;
6561 return Proc_Id;
6562 end Make_Deep_Proc;
6564 ---------------------------
6565 -- Make_Deep_Record_Body --
6566 ---------------------------
6568 function Make_Deep_Record_Body
6569 (Prim : Final_Primitives;
6570 Typ : Entity_Id;
6571 Is_Local : Boolean := False) return List_Id
6573 Exceptions_OK : constant Boolean := Exceptions_In_Finalization_OK;
6575 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
6576 -- Build the statements necessary to adjust a record type. The type may
6577 -- have discriminants and contain variant parts. Generate:
6579 -- begin
6580 -- begin
6581 -- [Deep_]Adjust (V.Comp_1);
6582 -- exception
6583 -- when Id : others =>
6584 -- if not Raised then
6585 -- Raised := True;
6586 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6587 -- end if;
6588 -- end;
6589 -- . . .
6590 -- begin
6591 -- [Deep_]Adjust (V.Comp_N);
6592 -- exception
6593 -- when Id : others =>
6594 -- if not Raised then
6595 -- Raised := True;
6596 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6597 -- end if;
6598 -- end;
6600 -- begin
6601 -- Deep_Adjust (V._parent, False); -- If applicable
6602 -- exception
6603 -- when Id : others =>
6604 -- if not Raised then
6605 -- Raised := True;
6606 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6607 -- end if;
6608 -- end;
6610 -- if F then
6611 -- begin
6612 -- Adjust (V); -- If applicable
6613 -- exception
6614 -- when others =>
6615 -- if not Raised then
6616 -- Raised := True;
6617 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6618 -- end if;
6619 -- end;
6620 -- end if;
6622 -- if Raised and then not Abort then
6623 -- Raise_From_Controlled_Operation (E);
6624 -- end if;
6625 -- end;
6627 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
6628 -- Build the statements necessary to finalize a record type. The type
6629 -- may have discriminants and contain variant parts. Generate:
6631 -- declare
6632 -- Abort : constant Boolean := Triggered_By_Abort;
6633 -- <or>
6634 -- Abort : constant Boolean := False; -- no abort
6635 -- E : Exception_Occurrence;
6636 -- Raised : Boolean := False;
6638 -- begin
6639 -- if F then
6640 -- begin
6641 -- Finalize (V); -- If applicable
6642 -- exception
6643 -- when others =>
6644 -- if not Raised then
6645 -- Raised := True;
6646 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6647 -- end if;
6648 -- end;
6649 -- end if;
6651 -- case Variant_1 is
6652 -- when Value_1 =>
6653 -- case State_Counter_N => -- If Is_Local is enabled
6654 -- when N => .
6655 -- goto LN; .
6656 -- ... .
6657 -- when 1 => .
6658 -- goto L1; .
6659 -- when others => .
6660 -- goto L0; .
6661 -- end case; .
6663 -- <<LN>> -- If Is_Local is enabled
6664 -- begin
6665 -- [Deep_]Finalize (V.Comp_N);
6666 -- exception
6667 -- when others =>
6668 -- if not Raised then
6669 -- Raised := True;
6670 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6671 -- end if;
6672 -- end;
6673 -- . . .
6674 -- <<L1>>
6675 -- begin
6676 -- [Deep_]Finalize (V.Comp_1);
6677 -- exception
6678 -- when others =>
6679 -- if not Raised then
6680 -- Raised := True;
6681 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6682 -- end if;
6683 -- end;
6684 -- <<L0>>
6685 -- end case;
6687 -- case State_Counter_1 => -- If Is_Local is enabled
6688 -- when M => .
6689 -- goto LM; .
6690 -- ...
6692 -- begin
6693 -- Deep_Finalize (V._parent, False); -- If applicable
6694 -- exception
6695 -- when Id : others =>
6696 -- if not Raised then
6697 -- Raised := True;
6698 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6699 -- end if;
6700 -- end;
6702 -- if Raised and then not Abort then
6703 -- Raise_From_Controlled_Operation (E);
6704 -- end if;
6705 -- end;
6707 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
6708 -- Given a derived tagged type Typ, traverse all components, find field
6709 -- _parent and return its type.
6711 procedure Preprocess_Components
6712 (Comps : Node_Id;
6713 Num_Comps : out Nat;
6714 Has_POC : out Boolean);
6715 -- Examine all components in component list Comps, count all controlled
6716 -- components and determine whether at least one of them is per-object
6717 -- constrained. Component _parent is always skipped.
6719 -----------------------------
6720 -- Build_Adjust_Statements --
6721 -----------------------------
6723 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
6724 Loc : constant Source_Ptr := Sloc (Typ);
6725 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
6727 Finalizer_Data : Finalization_Exception_Data;
6729 function Process_Component_List_For_Adjust
6730 (Comps : Node_Id) return List_Id;
6731 -- Build all necessary adjust statements for a single component list
6733 ---------------------------------------
6734 -- Process_Component_List_For_Adjust --
6735 ---------------------------------------
6737 function Process_Component_List_For_Adjust
6738 (Comps : Node_Id) return List_Id
6740 Stmts : constant List_Id := New_List;
6742 procedure Process_Component_For_Adjust (Decl : Node_Id);
6743 -- Process the declaration of a single controlled component
6745 ----------------------------------
6746 -- Process_Component_For_Adjust --
6747 ----------------------------------
6749 procedure Process_Component_For_Adjust (Decl : Node_Id) is
6750 Id : constant Entity_Id := Defining_Identifier (Decl);
6751 Typ : constant Entity_Id := Etype (Id);
6753 Adj_Call : Node_Id;
6755 begin
6756 -- begin
6757 -- [Deep_]Adjust (V.Id);
6759 -- exception
6760 -- when others =>
6761 -- if not Raised then
6762 -- Raised := True;
6763 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6764 -- end if;
6765 -- end;
6767 Adj_Call :=
6768 Make_Adjust_Call (
6769 Obj_Ref =>
6770 Make_Selected_Component (Loc,
6771 Prefix => Make_Identifier (Loc, Name_V),
6772 Selector_Name => Make_Identifier (Loc, Chars (Id))),
6773 Typ => Typ);
6775 -- Guard against a missing [Deep_]Adjust when the component
6776 -- type was not properly frozen.
6778 if Present (Adj_Call) then
6779 if Exceptions_OK then
6780 Adj_Call :=
6781 Make_Block_Statement (Loc,
6782 Handled_Statement_Sequence =>
6783 Make_Handled_Sequence_Of_Statements (Loc,
6784 Statements => New_List (Adj_Call),
6785 Exception_Handlers => New_List (
6786 Build_Exception_Handler (Finalizer_Data))));
6787 end if;
6789 Append_To (Stmts, Adj_Call);
6790 end if;
6791 end Process_Component_For_Adjust;
6793 -- Local variables
6795 Decl : Node_Id;
6796 Decl_Id : Entity_Id;
6797 Decl_Typ : Entity_Id;
6798 Has_POC : Boolean;
6799 Num_Comps : Nat;
6800 Var_Case : Node_Id;
6802 -- Start of processing for Process_Component_List_For_Adjust
6804 begin
6805 -- Perform an initial check, determine the number of controlled
6806 -- components in the current list and whether at least one of them
6807 -- is per-object constrained.
6809 Preprocess_Components (Comps, Num_Comps, Has_POC);
6811 -- The processing in this routine is done in the following order:
6812 -- 1) Regular components
6813 -- 2) Per-object constrained components
6814 -- 3) Variant parts
6816 if Num_Comps > 0 then
6818 -- Process all regular components in order of declarations
6820 Decl := First_Non_Pragma (Component_Items (Comps));
6821 while Present (Decl) loop
6822 Decl_Id := Defining_Identifier (Decl);
6823 Decl_Typ := Etype (Decl_Id);
6825 -- Skip _parent as well as per-object constrained components
6827 if Chars (Decl_Id) /= Name_uParent
6828 and then Needs_Finalization (Decl_Typ)
6829 then
6830 if Has_Access_Constraint (Decl_Id)
6831 and then No (Expression (Decl))
6832 then
6833 null;
6834 else
6835 Process_Component_For_Adjust (Decl);
6836 end if;
6837 end if;
6839 Next_Non_Pragma (Decl);
6840 end loop;
6842 -- Process all per-object constrained components in order of
6843 -- declarations.
6845 if Has_POC then
6846 Decl := First_Non_Pragma (Component_Items (Comps));
6847 while Present (Decl) loop
6848 Decl_Id := Defining_Identifier (Decl);
6849 Decl_Typ := Etype (Decl_Id);
6851 -- Skip _parent
6853 if Chars (Decl_Id) /= Name_uParent
6854 and then Needs_Finalization (Decl_Typ)
6855 and then Has_Access_Constraint (Decl_Id)
6856 and then No (Expression (Decl))
6857 then
6858 Process_Component_For_Adjust (Decl);
6859 end if;
6861 Next_Non_Pragma (Decl);
6862 end loop;
6863 end if;
6864 end if;
6866 -- Process all variants, if any
6868 Var_Case := Empty;
6869 if Present (Variant_Part (Comps)) then
6870 declare
6871 Var_Alts : constant List_Id := New_List;
6872 Var : Node_Id;
6874 begin
6875 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
6876 while Present (Var) loop
6878 -- Generate:
6879 -- when <discrete choices> =>
6880 -- <adjust statements>
6882 Append_To (Var_Alts,
6883 Make_Case_Statement_Alternative (Loc,
6884 Discrete_Choices =>
6885 New_Copy_List (Discrete_Choices (Var)),
6886 Statements =>
6887 Process_Component_List_For_Adjust (
6888 Component_List (Var))));
6890 Next_Non_Pragma (Var);
6891 end loop;
6893 -- Generate:
6894 -- case V.<discriminant> is
6895 -- when <discrete choices 1> =>
6896 -- <adjust statements 1>
6897 -- ...
6898 -- when <discrete choices N> =>
6899 -- <adjust statements N>
6900 -- end case;
6902 Var_Case :=
6903 Make_Case_Statement (Loc,
6904 Expression =>
6905 Make_Selected_Component (Loc,
6906 Prefix => Make_Identifier (Loc, Name_V),
6907 Selector_Name =>
6908 Make_Identifier (Loc,
6909 Chars => Chars (Name (Variant_Part (Comps))))),
6910 Alternatives => Var_Alts);
6911 end;
6912 end if;
6914 -- Add the variant case statement to the list of statements
6916 if Present (Var_Case) then
6917 Append_To (Stmts, Var_Case);
6918 end if;
6920 -- If the component list did not have any controlled components
6921 -- nor variants, return null.
6923 if Is_Empty_List (Stmts) then
6924 Append_To (Stmts, Make_Null_Statement (Loc));
6925 end if;
6927 return Stmts;
6928 end Process_Component_List_For_Adjust;
6930 -- Local variables
6932 Bod_Stmts : List_Id := No_List;
6933 Finalizer_Decls : List_Id := No_List;
6934 Rec_Def : Node_Id;
6936 -- Start of processing for Build_Adjust_Statements
6938 begin
6939 Finalizer_Decls := New_List;
6940 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
6942 if Nkind (Typ_Def) = N_Derived_Type_Definition then
6943 Rec_Def := Record_Extension_Part (Typ_Def);
6944 else
6945 Rec_Def := Typ_Def;
6946 end if;
6948 -- Create an adjust sequence for all record components
6950 if Present (Component_List (Rec_Def)) then
6951 Bod_Stmts :=
6952 Process_Component_List_For_Adjust (Component_List (Rec_Def));
6953 end if;
6955 -- A derived record type must adjust all inherited components. This
6956 -- action poses the following problem:
6958 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6959 -- begin
6960 -- Adjust (Obj);
6961 -- ...
6963 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6964 -- begin
6965 -- Deep_Adjust (Obj._parent);
6966 -- ...
6967 -- Adjust (Obj);
6968 -- ...
6970 -- Adjusting the derived type will invoke Adjust of the parent and
6971 -- then that of the derived type. This is undesirable because both
6972 -- routines may modify shared components. Only the Adjust of the
6973 -- derived type should be invoked.
6975 -- To prevent this double adjustment of shared components,
6976 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6978 -- procedure Deep_Adjust
6979 -- (Obj : in out Some_Type;
6980 -- Flag : Boolean := True)
6981 -- is
6982 -- begin
6983 -- if Flag then
6984 -- Adjust (Obj);
6985 -- end if;
6986 -- ...
6988 -- When Deep_Adjust is invokes for field _parent, a value of False is
6989 -- provided for the flag:
6991 -- Deep_Adjust (Obj._parent, False);
6993 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
6994 declare
6995 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
6996 Adj_Stmt : Node_Id;
6997 Call : Node_Id;
6999 begin
7000 if Needs_Finalization (Par_Typ) then
7001 Call :=
7002 Make_Adjust_Call
7003 (Obj_Ref =>
7004 Make_Selected_Component (Loc,
7005 Prefix => Make_Identifier (Loc, Name_V),
7006 Selector_Name =>
7007 Make_Identifier (Loc, Name_uParent)),
7008 Typ => Par_Typ,
7009 Skip_Self => True);
7011 -- Generate:
7012 -- begin
7013 -- Deep_Adjust (V._parent, False);
7015 -- exception
7016 -- when Id : others =>
7017 -- if not Raised then
7018 -- Raised := True;
7019 -- Save_Occurrence (E,
7020 -- Get_Current_Excep.all.all);
7021 -- end if;
7022 -- end;
7024 if Present (Call) then
7025 Adj_Stmt := Call;
7027 if Exceptions_OK then
7028 Adj_Stmt :=
7029 Make_Block_Statement (Loc,
7030 Handled_Statement_Sequence =>
7031 Make_Handled_Sequence_Of_Statements (Loc,
7032 Statements => New_List (Adj_Stmt),
7033 Exception_Handlers => New_List (
7034 Build_Exception_Handler (Finalizer_Data))));
7035 end if;
7037 Prepend_To (Bod_Stmts, Adj_Stmt);
7038 end if;
7039 end if;
7040 end;
7041 end if;
7043 -- Adjust the object. This action must be performed last after all
7044 -- components have been adjusted.
7046 if Is_Controlled (Typ) then
7047 declare
7048 Adj_Stmt : Node_Id;
7049 Proc : Entity_Id;
7051 begin
7052 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
7054 -- Generate:
7055 -- if F then
7056 -- begin
7057 -- Adjust (V);
7059 -- exception
7060 -- when others =>
7061 -- if not Raised then
7062 -- Raised := True;
7063 -- Save_Occurrence (E,
7064 -- Get_Current_Excep.all.all);
7065 -- end if;
7066 -- end;
7067 -- end if;
7069 if Present (Proc) then
7070 Adj_Stmt :=
7071 Make_Procedure_Call_Statement (Loc,
7072 Name => New_Occurrence_Of (Proc, Loc),
7073 Parameter_Associations => New_List (
7074 Make_Identifier (Loc, Name_V)));
7076 if Exceptions_OK then
7077 Adj_Stmt :=
7078 Make_Block_Statement (Loc,
7079 Handled_Statement_Sequence =>
7080 Make_Handled_Sequence_Of_Statements (Loc,
7081 Statements => New_List (Adj_Stmt),
7082 Exception_Handlers => New_List (
7083 Build_Exception_Handler
7084 (Finalizer_Data))));
7085 end if;
7087 Append_To (Bod_Stmts,
7088 Make_If_Statement (Loc,
7089 Condition => Make_Identifier (Loc, Name_F),
7090 Then_Statements => New_List (Adj_Stmt)));
7091 end if;
7092 end;
7093 end if;
7095 -- At this point either all adjustment statements have been generated
7096 -- or the type is not controlled.
7098 if Is_Empty_List (Bod_Stmts) then
7099 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
7101 return Bod_Stmts;
7103 -- Generate:
7104 -- declare
7105 -- Abort : constant Boolean := Triggered_By_Abort;
7106 -- <or>
7107 -- Abort : constant Boolean := False; -- no abort
7109 -- E : Exception_Occurrence;
7110 -- Raised : Boolean := False;
7112 -- begin
7113 -- <adjust statements>
7115 -- if Raised and then not Abort then
7116 -- Raise_From_Controlled_Operation (E);
7117 -- end if;
7118 -- end;
7120 else
7121 if Exceptions_OK then
7122 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7123 end if;
7125 return
7126 New_List (
7127 Make_Block_Statement (Loc,
7128 Declarations =>
7129 Finalizer_Decls,
7130 Handled_Statement_Sequence =>
7131 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7132 end if;
7133 end Build_Adjust_Statements;
7135 -------------------------------
7136 -- Build_Finalize_Statements --
7137 -------------------------------
7139 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
7140 Loc : constant Source_Ptr := Sloc (Typ);
7141 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7143 Counter : Int := 0;
7144 Finalizer_Data : Finalization_Exception_Data;
7146 function Process_Component_List_For_Finalize
7147 (Comps : Node_Id) return List_Id;
7148 -- Build all necessary finalization statements for a single component
7149 -- list. The statements may include a jump circuitry if flag Is_Local
7150 -- is enabled.
7152 -----------------------------------------
7153 -- Process_Component_List_For_Finalize --
7154 -----------------------------------------
7156 function Process_Component_List_For_Finalize
7157 (Comps : Node_Id) return List_Id
7159 procedure Process_Component_For_Finalize
7160 (Decl : Node_Id;
7161 Alts : List_Id;
7162 Decls : List_Id;
7163 Stmts : List_Id;
7164 Num_Comps : in out Nat);
7165 -- Process the declaration of a single controlled component. If
7166 -- flag Is_Local is enabled, create the corresponding label and
7167 -- jump circuitry. Alts is the list of case alternatives, Decls
7168 -- is the top level declaration list where labels are declared
7169 -- and Stmts is the list of finalization actions. Num_Comps
7170 -- denotes the current number of components needing finalization.
7172 ------------------------------------
7173 -- Process_Component_For_Finalize --
7174 ------------------------------------
7176 procedure Process_Component_For_Finalize
7177 (Decl : Node_Id;
7178 Alts : List_Id;
7179 Decls : List_Id;
7180 Stmts : List_Id;
7181 Num_Comps : in out Nat)
7183 Id : constant Entity_Id := Defining_Identifier (Decl);
7184 Typ : constant Entity_Id := Etype (Id);
7185 Fin_Call : Node_Id;
7187 begin
7188 if Is_Local then
7189 declare
7190 Label : Node_Id;
7191 Label_Id : Entity_Id;
7193 begin
7194 -- Generate:
7195 -- LN : label;
7197 Label_Id :=
7198 Make_Identifier (Loc,
7199 Chars => New_External_Name ('L', Num_Comps));
7200 Set_Entity (Label_Id,
7201 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7202 Label := Make_Label (Loc, Label_Id);
7204 Append_To (Decls,
7205 Make_Implicit_Label_Declaration (Loc,
7206 Defining_Identifier => Entity (Label_Id),
7207 Label_Construct => Label));
7209 -- Generate:
7210 -- when N =>
7211 -- goto LN;
7213 Append_To (Alts,
7214 Make_Case_Statement_Alternative (Loc,
7215 Discrete_Choices => New_List (
7216 Make_Integer_Literal (Loc, Num_Comps)),
7218 Statements => New_List (
7219 Make_Goto_Statement (Loc,
7220 Name =>
7221 New_Occurrence_Of (Entity (Label_Id), Loc)))));
7223 -- Generate:
7224 -- <<LN>>
7226 Append_To (Stmts, Label);
7228 -- Decrease the number of components to be processed.
7229 -- This action yields a new Label_Id in future calls.
7231 Num_Comps := Num_Comps - 1;
7232 end;
7233 end if;
7235 -- Generate:
7236 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7238 -- begin -- Exception handlers allowed
7239 -- [Deep_]Finalize (V.Id);
7240 -- exception
7241 -- when others =>
7242 -- if not Raised then
7243 -- Raised := True;
7244 -- Save_Occurrence (E,
7245 -- Get_Current_Excep.all.all);
7246 -- end if;
7247 -- end;
7249 Fin_Call :=
7250 Make_Final_Call
7251 (Obj_Ref =>
7252 Make_Selected_Component (Loc,
7253 Prefix => Make_Identifier (Loc, Name_V),
7254 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7255 Typ => Typ);
7257 -- Guard against a missing [Deep_]Finalize when the component
7258 -- type was not properly frozen.
7260 if Present (Fin_Call) then
7261 if Exceptions_OK then
7262 Fin_Call :=
7263 Make_Block_Statement (Loc,
7264 Handled_Statement_Sequence =>
7265 Make_Handled_Sequence_Of_Statements (Loc,
7266 Statements => New_List (Fin_Call),
7267 Exception_Handlers => New_List (
7268 Build_Exception_Handler (Finalizer_Data))));
7269 end if;
7271 Append_To (Stmts, Fin_Call);
7272 end if;
7273 end Process_Component_For_Finalize;
7275 -- Local variables
7277 Alts : List_Id;
7278 Counter_Id : Entity_Id := Empty;
7279 Decl : Node_Id;
7280 Decl_Id : Entity_Id;
7281 Decl_Typ : Entity_Id;
7282 Decls : List_Id;
7283 Has_POC : Boolean;
7284 Jump_Block : Node_Id;
7285 Label : Node_Id;
7286 Label_Id : Entity_Id;
7287 Num_Comps : Nat;
7288 Stmts : List_Id;
7289 Var_Case : Node_Id;
7291 -- Start of processing for Process_Component_List_For_Finalize
7293 begin
7294 -- Perform an initial check, look for controlled and per-object
7295 -- constrained components.
7297 Preprocess_Components (Comps, Num_Comps, Has_POC);
7299 -- Create a state counter to service the current component list.
7300 -- This step is performed before the variants are inspected in
7301 -- order to generate the same state counter names as those from
7302 -- Build_Initialize_Statements.
7304 if Num_Comps > 0 and then Is_Local then
7305 Counter := Counter + 1;
7307 Counter_Id :=
7308 Make_Defining_Identifier (Loc,
7309 Chars => New_External_Name ('C', Counter));
7310 end if;
7312 -- Process the component in the following order:
7313 -- 1) Variants
7314 -- 2) Per-object constrained components
7315 -- 3) Regular components
7317 -- Start with the variant parts
7319 Var_Case := Empty;
7320 if Present (Variant_Part (Comps)) then
7321 declare
7322 Var_Alts : constant List_Id := New_List;
7323 Var : Node_Id;
7325 begin
7326 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7327 while Present (Var) loop
7329 -- Generate:
7330 -- when <discrete choices> =>
7331 -- <finalize statements>
7333 Append_To (Var_Alts,
7334 Make_Case_Statement_Alternative (Loc,
7335 Discrete_Choices =>
7336 New_Copy_List (Discrete_Choices (Var)),
7337 Statements =>
7338 Process_Component_List_For_Finalize (
7339 Component_List (Var))));
7341 Next_Non_Pragma (Var);
7342 end loop;
7344 -- Generate:
7345 -- case V.<discriminant> is
7346 -- when <discrete choices 1> =>
7347 -- <finalize statements 1>
7348 -- ...
7349 -- when <discrete choices N> =>
7350 -- <finalize statements N>
7351 -- end case;
7353 Var_Case :=
7354 Make_Case_Statement (Loc,
7355 Expression =>
7356 Make_Selected_Component (Loc,
7357 Prefix => Make_Identifier (Loc, Name_V),
7358 Selector_Name =>
7359 Make_Identifier (Loc,
7360 Chars => Chars (Name (Variant_Part (Comps))))),
7361 Alternatives => Var_Alts);
7362 end;
7363 end if;
7365 -- The current component list does not have a single controlled
7366 -- component, however it may contain variants. Return the case
7367 -- statement for the variants or nothing.
7369 if Num_Comps = 0 then
7370 if Present (Var_Case) then
7371 return New_List (Var_Case);
7372 else
7373 return New_List (Make_Null_Statement (Loc));
7374 end if;
7375 end if;
7377 -- Prepare all lists
7379 Alts := New_List;
7380 Decls := New_List;
7381 Stmts := New_List;
7383 -- Process all per-object constrained components in reverse order
7385 if Has_POC then
7386 Decl := Last_Non_Pragma (Component_Items (Comps));
7387 while Present (Decl) loop
7388 Decl_Id := Defining_Identifier (Decl);
7389 Decl_Typ := Etype (Decl_Id);
7391 -- Skip _parent
7393 if Chars (Decl_Id) /= Name_uParent
7394 and then Needs_Finalization (Decl_Typ)
7395 and then Has_Access_Constraint (Decl_Id)
7396 and then No (Expression (Decl))
7397 then
7398 Process_Component_For_Finalize
7399 (Decl, Alts, Decls, Stmts, Num_Comps);
7400 end if;
7402 Prev_Non_Pragma (Decl);
7403 end loop;
7404 end if;
7406 -- Process the rest of the components in reverse order
7408 Decl := Last_Non_Pragma (Component_Items (Comps));
7409 while Present (Decl) loop
7410 Decl_Id := Defining_Identifier (Decl);
7411 Decl_Typ := Etype (Decl_Id);
7413 -- Skip _parent
7415 if Chars (Decl_Id) /= Name_uParent
7416 and then Needs_Finalization (Decl_Typ)
7417 then
7418 -- Skip per-object constrained components since they were
7419 -- handled in the above step.
7421 if Has_Access_Constraint (Decl_Id)
7422 and then No (Expression (Decl))
7423 then
7424 null;
7425 else
7426 Process_Component_For_Finalize
7427 (Decl, Alts, Decls, Stmts, Num_Comps);
7428 end if;
7429 end if;
7431 Prev_Non_Pragma (Decl);
7432 end loop;
7434 -- Generate:
7435 -- declare
7436 -- LN : label; -- If Is_Local is enabled
7437 -- ... .
7438 -- L0 : label; .
7440 -- begin .
7441 -- case CounterX is .
7442 -- when N => .
7443 -- goto LN; .
7444 -- ... .
7445 -- when 1 => .
7446 -- goto L1; .
7447 -- when others => .
7448 -- goto L0; .
7449 -- end case; .
7451 -- <<LN>> -- If Is_Local is enabled
7452 -- begin
7453 -- [Deep_]Finalize (V.CompY);
7454 -- exception
7455 -- when Id : others =>
7456 -- if not Raised then
7457 -- Raised := True;
7458 -- Save_Occurrence (E,
7459 -- Get_Current_Excep.all.all);
7460 -- end if;
7461 -- end;
7462 -- ...
7463 -- <<L0>> -- If Is_Local is enabled
7464 -- end;
7466 if Is_Local then
7468 -- Add the declaration of default jump location L0, its
7469 -- corresponding alternative and its place in the statements.
7471 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
7472 Set_Entity (Label_Id,
7473 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7474 Label := Make_Label (Loc, Label_Id);
7476 Append_To (Decls, -- declaration
7477 Make_Implicit_Label_Declaration (Loc,
7478 Defining_Identifier => Entity (Label_Id),
7479 Label_Construct => Label));
7481 Append_To (Alts, -- alternative
7482 Make_Case_Statement_Alternative (Loc,
7483 Discrete_Choices => New_List (
7484 Make_Others_Choice (Loc)),
7486 Statements => New_List (
7487 Make_Goto_Statement (Loc,
7488 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
7490 Append_To (Stmts, Label); -- statement
7492 -- Create the jump block
7494 Prepend_To (Stmts,
7495 Make_Case_Statement (Loc,
7496 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
7497 Alternatives => Alts));
7498 end if;
7500 Jump_Block :=
7501 Make_Block_Statement (Loc,
7502 Declarations => Decls,
7503 Handled_Statement_Sequence =>
7504 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7506 if Present (Var_Case) then
7507 return New_List (Var_Case, Jump_Block);
7508 else
7509 return New_List (Jump_Block);
7510 end if;
7511 end Process_Component_List_For_Finalize;
7513 -- Local variables
7515 Bod_Stmts : List_Id := No_List;
7516 Finalizer_Decls : List_Id := No_List;
7517 Rec_Def : Node_Id;
7519 -- Start of processing for Build_Finalize_Statements
7521 begin
7522 Finalizer_Decls := New_List;
7523 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7525 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7526 Rec_Def := Record_Extension_Part (Typ_Def);
7527 else
7528 Rec_Def := Typ_Def;
7529 end if;
7531 -- Create a finalization sequence for all record components
7533 if Present (Component_List (Rec_Def)) then
7534 Bod_Stmts :=
7535 Process_Component_List_For_Finalize (Component_List (Rec_Def));
7536 end if;
7538 -- A derived record type must finalize all inherited components. This
7539 -- action poses the following problem:
7541 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7542 -- begin
7543 -- Finalize (Obj);
7544 -- ...
7546 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7547 -- begin
7548 -- Deep_Finalize (Obj._parent);
7549 -- ...
7550 -- Finalize (Obj);
7551 -- ...
7553 -- Finalizing the derived type will invoke Finalize of the parent and
7554 -- then that of the derived type. This is undesirable because both
7555 -- routines may modify shared components. Only the Finalize of the
7556 -- derived type should be invoked.
7558 -- To prevent this double adjustment of shared components,
7559 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7561 -- procedure Deep_Finalize
7562 -- (Obj : in out Some_Type;
7563 -- Flag : Boolean := True)
7564 -- is
7565 -- begin
7566 -- if Flag then
7567 -- Finalize (Obj);
7568 -- end if;
7569 -- ...
7571 -- When Deep_Finalize is invoked for field _parent, a value of False
7572 -- is provided for the flag:
7574 -- Deep_Finalize (Obj._parent, False);
7576 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7577 declare
7578 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7579 Call : Node_Id;
7580 Fin_Stmt : Node_Id;
7582 begin
7583 if Needs_Finalization (Par_Typ) then
7584 Call :=
7585 Make_Final_Call
7586 (Obj_Ref =>
7587 Make_Selected_Component (Loc,
7588 Prefix => Make_Identifier (Loc, Name_V),
7589 Selector_Name =>
7590 Make_Identifier (Loc, Name_uParent)),
7591 Typ => Par_Typ,
7592 Skip_Self => True);
7594 -- Generate:
7595 -- begin
7596 -- Deep_Finalize (V._parent, False);
7598 -- exception
7599 -- when Id : others =>
7600 -- if not Raised then
7601 -- Raised := True;
7602 -- Save_Occurrence (E,
7603 -- Get_Current_Excep.all.all);
7604 -- end if;
7605 -- end;
7607 if Present (Call) then
7608 Fin_Stmt := Call;
7610 if Exceptions_OK then
7611 Fin_Stmt :=
7612 Make_Block_Statement (Loc,
7613 Handled_Statement_Sequence =>
7614 Make_Handled_Sequence_Of_Statements (Loc,
7615 Statements => New_List (Fin_Stmt),
7616 Exception_Handlers => New_List (
7617 Build_Exception_Handler
7618 (Finalizer_Data))));
7619 end if;
7621 Append_To (Bod_Stmts, Fin_Stmt);
7622 end if;
7623 end if;
7624 end;
7625 end if;
7627 -- Finalize the object. This action must be performed first before
7628 -- all components have been finalized.
7630 if Is_Controlled (Typ) and then not Is_Local then
7631 declare
7632 Fin_Stmt : Node_Id;
7633 Proc : Entity_Id;
7635 begin
7636 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
7638 -- Generate:
7639 -- if F then
7640 -- begin
7641 -- Finalize (V);
7643 -- exception
7644 -- when others =>
7645 -- if not Raised then
7646 -- Raised := True;
7647 -- Save_Occurrence (E,
7648 -- Get_Current_Excep.all.all);
7649 -- end if;
7650 -- end;
7651 -- end if;
7653 if Present (Proc) then
7654 Fin_Stmt :=
7655 Make_Procedure_Call_Statement (Loc,
7656 Name => New_Occurrence_Of (Proc, Loc),
7657 Parameter_Associations => New_List (
7658 Make_Identifier (Loc, Name_V)));
7660 if Exceptions_OK then
7661 Fin_Stmt :=
7662 Make_Block_Statement (Loc,
7663 Handled_Statement_Sequence =>
7664 Make_Handled_Sequence_Of_Statements (Loc,
7665 Statements => New_List (Fin_Stmt),
7666 Exception_Handlers => New_List (
7667 Build_Exception_Handler
7668 (Finalizer_Data))));
7669 end if;
7671 Prepend_To (Bod_Stmts,
7672 Make_If_Statement (Loc,
7673 Condition => Make_Identifier (Loc, Name_F),
7674 Then_Statements => New_List (Fin_Stmt)));
7675 end if;
7676 end;
7677 end if;
7679 -- At this point either all finalization statements have been
7680 -- generated or the type is not controlled.
7682 if No (Bod_Stmts) then
7683 return New_List (Make_Null_Statement (Loc));
7685 -- Generate:
7686 -- declare
7687 -- Abort : constant Boolean := Triggered_By_Abort;
7688 -- <or>
7689 -- Abort : constant Boolean := False; -- no abort
7691 -- E : Exception_Occurrence;
7692 -- Raised : Boolean := False;
7694 -- begin
7695 -- <finalize statements>
7697 -- if Raised and then not Abort then
7698 -- Raise_From_Controlled_Operation (E);
7699 -- end if;
7700 -- end;
7702 else
7703 if Exceptions_OK then
7704 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7705 end if;
7707 return
7708 New_List (
7709 Make_Block_Statement (Loc,
7710 Declarations =>
7711 Finalizer_Decls,
7712 Handled_Statement_Sequence =>
7713 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7714 end if;
7715 end Build_Finalize_Statements;
7717 -----------------------
7718 -- Parent_Field_Type --
7719 -----------------------
7721 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
7722 Field : Entity_Id;
7724 begin
7725 Field := First_Entity (Typ);
7726 while Present (Field) loop
7727 if Chars (Field) = Name_uParent then
7728 return Etype (Field);
7729 end if;
7731 Next_Entity (Field);
7732 end loop;
7734 -- A derived tagged type should always have a parent field
7736 raise Program_Error;
7737 end Parent_Field_Type;
7739 ---------------------------
7740 -- Preprocess_Components --
7741 ---------------------------
7743 procedure Preprocess_Components
7744 (Comps : Node_Id;
7745 Num_Comps : out Nat;
7746 Has_POC : out Boolean)
7748 Decl : Node_Id;
7749 Id : Entity_Id;
7750 Typ : Entity_Id;
7752 begin
7753 Num_Comps := 0;
7754 Has_POC := False;
7756 Decl := First_Non_Pragma (Component_Items (Comps));
7757 while Present (Decl) loop
7758 Id := Defining_Identifier (Decl);
7759 Typ := Etype (Id);
7761 -- Skip field _parent
7763 if Chars (Id) /= Name_uParent
7764 and then Needs_Finalization (Typ)
7765 then
7766 Num_Comps := Num_Comps + 1;
7768 if Has_Access_Constraint (Id)
7769 and then No (Expression (Decl))
7770 then
7771 Has_POC := True;
7772 end if;
7773 end if;
7775 Next_Non_Pragma (Decl);
7776 end loop;
7777 end Preprocess_Components;
7779 -- Start of processing for Make_Deep_Record_Body
7781 begin
7782 case Prim is
7783 when Address_Case =>
7784 return Make_Finalize_Address_Stmts (Typ);
7786 when Adjust_Case =>
7787 return Build_Adjust_Statements (Typ);
7789 when Finalize_Case =>
7790 return Build_Finalize_Statements (Typ);
7792 when Initialize_Case =>
7793 declare
7794 Loc : constant Source_Ptr := Sloc (Typ);
7796 begin
7797 if Is_Controlled (Typ) then
7798 return New_List (
7799 Make_Procedure_Call_Statement (Loc,
7800 Name =>
7801 New_Occurrence_Of
7802 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
7803 Parameter_Associations => New_List (
7804 Make_Identifier (Loc, Name_V))));
7805 else
7806 return Empty_List;
7807 end if;
7808 end;
7809 end case;
7810 end Make_Deep_Record_Body;
7812 ----------------------
7813 -- Make_Final_Call --
7814 ----------------------
7816 function Make_Final_Call
7817 (Obj_Ref : Node_Id;
7818 Typ : Entity_Id;
7819 Skip_Self : Boolean := False) return Node_Id
7821 Loc : constant Source_Ptr := Sloc (Obj_Ref);
7822 Atyp : Entity_Id;
7823 Fin_Id : Entity_Id := Empty;
7824 Ref : Node_Id;
7825 Utyp : Entity_Id;
7827 begin
7828 Ref := Obj_Ref;
7830 -- Recover the proper type which contains [Deep_]Finalize
7832 if Is_Class_Wide_Type (Typ) then
7833 Utyp := Root_Type (Typ);
7834 Atyp := Utyp;
7836 elsif Is_Concurrent_Type (Typ) then
7837 Utyp := Corresponding_Record_Type (Typ);
7838 Atyp := Empty;
7839 Ref := Convert_Concurrent (Ref, Typ);
7841 elsif Is_Private_Type (Typ)
7842 and then Present (Full_View (Typ))
7843 and then Is_Concurrent_Type (Full_View (Typ))
7844 then
7845 Utyp := Corresponding_Record_Type (Full_View (Typ));
7846 Atyp := Typ;
7847 Ref := Convert_Concurrent (Ref, Full_View (Typ));
7849 else
7850 Utyp := Typ;
7851 Atyp := Typ;
7852 end if;
7854 Utyp := Underlying_Type (Base_Type (Utyp));
7855 Set_Assignment_OK (Ref);
7857 -- Deal with untagged derivation of private views. If the parent type
7858 -- is a protected type, Deep_Finalize is found on the corresponding
7859 -- record of the ancestor.
7861 if Is_Untagged_Derivation (Typ) then
7862 if Is_Protected_Type (Typ) then
7863 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
7864 else
7865 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
7867 if Is_Protected_Type (Utyp) then
7868 Utyp := Corresponding_Record_Type (Utyp);
7869 end if;
7870 end if;
7872 Ref := Unchecked_Convert_To (Utyp, Ref);
7873 Set_Assignment_OK (Ref);
7874 end if;
7876 -- Deal with derived private types which do not inherit primitives from
7877 -- their parents. In this case, [Deep_]Finalize can be found in the full
7878 -- view of the parent type.
7880 if Present (Utyp)
7881 and then Is_Tagged_Type (Utyp)
7882 and then Is_Derived_Type (Utyp)
7883 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
7884 and then Is_Private_Type (Etype (Utyp))
7885 and then Present (Full_View (Etype (Utyp)))
7886 then
7887 Utyp := Full_View (Etype (Utyp));
7888 Ref := Unchecked_Convert_To (Utyp, Ref);
7889 Set_Assignment_OK (Ref);
7890 end if;
7892 -- When dealing with the completion of a private type, use the base type
7893 -- instead.
7895 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
7896 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
7898 Utyp := Base_Type (Utyp);
7899 Ref := Unchecked_Convert_To (Utyp, Ref);
7900 Set_Assignment_OK (Ref);
7901 end if;
7903 -- The underlying type may not be present due to a missing full view. In
7904 -- this case freezing did not take place and there is no [Deep_]Finalize
7905 -- primitive to call.
7907 if No (Utyp) then
7908 return Empty;
7910 elsif Skip_Self then
7911 if Has_Controlled_Component (Utyp) then
7912 if Is_Tagged_Type (Utyp) then
7913 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7914 else
7915 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7916 end if;
7917 end if;
7919 -- Class-wide types, interfaces and types with controlled components
7921 elsif Is_Class_Wide_Type (Typ)
7922 or else Is_Interface (Typ)
7923 or else Has_Controlled_Component (Utyp)
7924 then
7925 if Is_Tagged_Type (Utyp) then
7926 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7927 else
7928 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
7929 end if;
7931 -- Derivations from [Limited_]Controlled
7933 elsif Is_Controlled (Utyp) then
7934 if Has_Controlled_Component (Utyp) then
7935 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7936 else
7937 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
7938 end if;
7940 -- Tagged types
7942 elsif Is_Tagged_Type (Utyp) then
7943 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
7945 else
7946 raise Program_Error;
7947 end if;
7949 if Present (Fin_Id) then
7951 -- When finalizing a class-wide object, do not convert to the root
7952 -- type in order to produce a dispatching call.
7954 if Is_Class_Wide_Type (Typ) then
7955 null;
7957 -- Ensure that a finalization routine is at least decorated in order
7958 -- to inspect the object parameter.
7960 elsif Analyzed (Fin_Id)
7961 or else Ekind (Fin_Id) = E_Procedure
7962 then
7963 -- In certain cases, such as the creation of Stream_Read, the
7964 -- visible entity of the type is its full view. Since Stream_Read
7965 -- will have to create an object of type Typ, the local object
7966 -- will be finalzed by the scope finalizer generated later on. The
7967 -- object parameter of Deep_Finalize will always use the private
7968 -- view of the type. To avoid such a clash between a private and a
7969 -- full view, perform an unchecked conversion of the object
7970 -- reference to the private view.
7972 declare
7973 Formal_Typ : constant Entity_Id :=
7974 Etype (First_Formal (Fin_Id));
7975 begin
7976 if Is_Private_Type (Formal_Typ)
7977 and then Present (Full_View (Formal_Typ))
7978 and then Full_View (Formal_Typ) = Utyp
7979 then
7980 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
7981 end if;
7982 end;
7984 Ref := Convert_View (Fin_Id, Ref);
7985 end if;
7987 return
7988 Make_Call (Loc,
7989 Proc_Id => Fin_Id,
7990 Param => Ref,
7991 Skip_Self => Skip_Self);
7992 else
7993 return Empty;
7994 end if;
7995 end Make_Final_Call;
7997 --------------------------------
7998 -- Make_Finalize_Address_Body --
7999 --------------------------------
8001 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
8002 Is_Task : constant Boolean :=
8003 Ekind (Typ) = E_Record_Type
8004 and then Is_Concurrent_Record_Type (Typ)
8005 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
8006 E_Task_Type;
8007 Loc : constant Source_Ptr := Sloc (Typ);
8008 Proc_Id : Entity_Id;
8009 Stmts : List_Id;
8011 begin
8012 -- The corresponding records of task types are not controlled by design.
8013 -- For the sake of completeness, create an empty Finalize_Address to be
8014 -- used in task class-wide allocations.
8016 if Is_Task then
8017 null;
8019 -- Nothing to do if the type is not controlled or it already has a
8020 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8021 -- come from source. These are usually generated for completeness and
8022 -- do not need the Finalize_Address primitive.
8024 elsif not Needs_Finalization (Typ)
8025 or else Present (TSS (Typ, TSS_Finalize_Address))
8026 or else
8027 (Is_Class_Wide_Type (Typ)
8028 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
8029 and then not Comes_From_Source (Root_Type (Typ)))
8030 then
8031 return;
8032 end if;
8034 -- Do not generate Finalize_Address routine for CodePeer
8036 if CodePeer_Mode then
8037 return;
8038 end if;
8040 Proc_Id :=
8041 Make_Defining_Identifier (Loc,
8042 Make_TSS_Name (Typ, TSS_Finalize_Address));
8044 -- Generate:
8046 -- procedure <Typ>FD (V : System.Address) is
8047 -- begin
8048 -- null; -- for tasks
8050 -- declare -- for all other types
8051 -- type Pnn is access all Typ;
8052 -- for Pnn'Storage_Size use 0;
8053 -- begin
8054 -- [Deep_]Finalize (Pnn (V).all);
8055 -- end;
8056 -- end TypFD;
8058 if Is_Task then
8059 Stmts := New_List (Make_Null_Statement (Loc));
8060 else
8061 Stmts := Make_Finalize_Address_Stmts (Typ);
8062 end if;
8064 Discard_Node (
8065 Make_Subprogram_Body (Loc,
8066 Specification =>
8067 Make_Procedure_Specification (Loc,
8068 Defining_Unit_Name => Proc_Id,
8070 Parameter_Specifications => New_List (
8071 Make_Parameter_Specification (Loc,
8072 Defining_Identifier =>
8073 Make_Defining_Identifier (Loc, Name_V),
8074 Parameter_Type =>
8075 New_Occurrence_Of (RTE (RE_Address), Loc)))),
8077 Declarations => No_List,
8079 Handled_Statement_Sequence =>
8080 Make_Handled_Sequence_Of_Statements (Loc,
8081 Statements => Stmts)));
8083 Set_TSS (Typ, Proc_Id);
8084 end Make_Finalize_Address_Body;
8086 ---------------------------------
8087 -- Make_Finalize_Address_Stmts --
8088 ---------------------------------
8090 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
8091 Loc : constant Source_Ptr := Sloc (Typ);
8093 Decls : List_Id;
8094 Desig_Typ : Entity_Id;
8095 Fin_Block : Node_Id;
8096 Fin_Call : Node_Id;
8097 Obj_Expr : Node_Id;
8098 Ptr_Typ : Entity_Id;
8100 begin
8101 if Is_Array_Type (Typ) then
8102 if Is_Constrained (First_Subtype (Typ)) then
8103 Desig_Typ := First_Subtype (Typ);
8104 else
8105 Desig_Typ := Base_Type (Typ);
8106 end if;
8108 -- Class-wide types of constrained root types
8110 elsif Is_Class_Wide_Type (Typ)
8111 and then Has_Discriminants (Root_Type (Typ))
8112 and then not
8113 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
8114 then
8115 declare
8116 Parent_Typ : Entity_Id;
8118 begin
8119 -- Climb the parent type chain looking for a non-constrained type
8121 Parent_Typ := Root_Type (Typ);
8122 while Parent_Typ /= Etype (Parent_Typ)
8123 and then Has_Discriminants (Parent_Typ)
8124 and then not
8125 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
8126 loop
8127 Parent_Typ := Etype (Parent_Typ);
8128 end loop;
8130 -- Handle views created for tagged types with unknown
8131 -- discriminants.
8133 if Is_Underlying_Record_View (Parent_Typ) then
8134 Parent_Typ := Underlying_Record_View (Parent_Typ);
8135 end if;
8137 Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
8138 end;
8140 -- General case
8142 else
8143 Desig_Typ := Typ;
8144 end if;
8146 -- Generate:
8147 -- type Ptr_Typ is access all Typ;
8148 -- for Ptr_Typ'Storage_Size use 0;
8150 Ptr_Typ := Make_Temporary (Loc, 'P');
8152 Decls := New_List (
8153 Make_Full_Type_Declaration (Loc,
8154 Defining_Identifier => Ptr_Typ,
8155 Type_Definition =>
8156 Make_Access_To_Object_Definition (Loc,
8157 All_Present => True,
8158 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
8160 Make_Attribute_Definition_Clause (Loc,
8161 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8162 Chars => Name_Storage_Size,
8163 Expression => Make_Integer_Literal (Loc, 0)));
8165 Obj_Expr := Make_Identifier (Loc, Name_V);
8167 -- Unconstrained arrays require special processing in order to retrieve
8168 -- the elements. To achieve this, we have to skip the dope vector which
8169 -- lays in front of the elements and then use a thin pointer to perform
8170 -- the address-to-access conversion.
8172 if Is_Array_Type (Typ)
8173 and then not Is_Constrained (First_Subtype (Typ))
8174 then
8175 declare
8176 Dope_Id : Entity_Id;
8178 begin
8179 -- Ensure that Ptr_Typ a thin pointer, generate:
8180 -- for Ptr_Typ'Size use System.Address'Size;
8182 Append_To (Decls,
8183 Make_Attribute_Definition_Clause (Loc,
8184 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8185 Chars => Name_Size,
8186 Expression =>
8187 Make_Integer_Literal (Loc, System_Address_Size)));
8189 -- Generate:
8190 -- Dnn : constant Storage_Offset :=
8191 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8193 Dope_Id := Make_Temporary (Loc, 'D');
8195 Append_To (Decls,
8196 Make_Object_Declaration (Loc,
8197 Defining_Identifier => Dope_Id,
8198 Constant_Present => True,
8199 Object_Definition =>
8200 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
8201 Expression =>
8202 Make_Op_Divide (Loc,
8203 Left_Opnd =>
8204 Make_Attribute_Reference (Loc,
8205 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
8206 Attribute_Name => Name_Descriptor_Size),
8207 Right_Opnd =>
8208 Make_Integer_Literal (Loc, System_Storage_Unit))));
8210 -- Shift the address from the start of the dope vector to the
8211 -- start of the elements:
8213 -- V + Dnn
8215 -- Note that this is done through a wrapper routine since RTSfind
8216 -- cannot retrieve operations with string names of the form "+".
8218 Obj_Expr :=
8219 Make_Function_Call (Loc,
8220 Name =>
8221 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
8222 Parameter_Associations => New_List (
8223 Obj_Expr,
8224 New_Occurrence_Of (Dope_Id, Loc)));
8225 end;
8226 end if;
8228 Fin_Call :=
8229 Make_Final_Call (
8230 Obj_Ref =>
8231 Make_Explicit_Dereference (Loc,
8232 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
8233 Typ => Desig_Typ);
8235 if Present (Fin_Call) then
8236 Fin_Block :=
8237 Make_Block_Statement (Loc,
8238 Declarations => Decls,
8239 Handled_Statement_Sequence =>
8240 Make_Handled_Sequence_Of_Statements (Loc,
8241 Statements => New_List (Fin_Call)));
8243 -- Otherwise previous errors or a missing full view may prevent the
8244 -- proper freezing of the designated type. If this is the case, there
8245 -- is no [Deep_]Finalize primitive to call.
8247 else
8248 Fin_Block := Make_Null_Statement (Loc);
8249 end if;
8251 return New_List (Fin_Block);
8252 end Make_Finalize_Address_Stmts;
8254 -------------------------------------
8255 -- Make_Handler_For_Ctrl_Operation --
8256 -------------------------------------
8258 -- Generate:
8260 -- when E : others =>
8261 -- Raise_From_Controlled_Operation (E);
8263 -- or:
8265 -- when others =>
8266 -- raise Program_Error [finalize raised exception];
8268 -- depending on whether Raise_From_Controlled_Operation is available
8270 function Make_Handler_For_Ctrl_Operation
8271 (Loc : Source_Ptr) return Node_Id
8273 E_Occ : Entity_Id;
8274 -- Choice parameter (for the first case above)
8276 Raise_Node : Node_Id;
8277 -- Procedure call or raise statement
8279 begin
8280 -- Standard run-time: add choice parameter E and pass it to
8281 -- Raise_From_Controlled_Operation so that the original exception
8282 -- name and message can be recorded in the exception message for
8283 -- Program_Error.
8285 if RTE_Available (RE_Raise_From_Controlled_Operation) then
8286 E_Occ := Make_Defining_Identifier (Loc, Name_E);
8287 Raise_Node :=
8288 Make_Procedure_Call_Statement (Loc,
8289 Name =>
8290 New_Occurrence_Of
8291 (RTE (RE_Raise_From_Controlled_Operation), Loc),
8292 Parameter_Associations => New_List (
8293 New_Occurrence_Of (E_Occ, Loc)));
8295 -- Restricted run-time: exception messages are not supported
8297 else
8298 E_Occ := Empty;
8299 Raise_Node :=
8300 Make_Raise_Program_Error (Loc,
8301 Reason => PE_Finalize_Raised_Exception);
8302 end if;
8304 return
8305 Make_Implicit_Exception_Handler (Loc,
8306 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8307 Choice_Parameter => E_Occ,
8308 Statements => New_List (Raise_Node));
8309 end Make_Handler_For_Ctrl_Operation;
8311 --------------------
8312 -- Make_Init_Call --
8313 --------------------
8315 function Make_Init_Call
8316 (Obj_Ref : Node_Id;
8317 Typ : Entity_Id) return Node_Id
8319 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8320 Is_Conc : Boolean;
8321 Proc : Entity_Id;
8322 Ref : Node_Id;
8323 Utyp : Entity_Id;
8325 begin
8326 Ref := Obj_Ref;
8328 -- Deal with the type and object reference. Depending on the context, an
8329 -- object reference may need several conversions.
8331 if Is_Concurrent_Type (Typ) then
8332 Is_Conc := True;
8333 Utyp := Corresponding_Record_Type (Typ);
8334 Ref := Convert_Concurrent (Ref, Typ);
8336 elsif Is_Private_Type (Typ)
8337 and then Present (Full_View (Typ))
8338 and then Is_Concurrent_Type (Underlying_Type (Typ))
8339 then
8340 Is_Conc := True;
8341 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8342 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8344 else
8345 Is_Conc := False;
8346 Utyp := Typ;
8347 end if;
8349 Utyp := Underlying_Type (Base_Type (Utyp));
8350 Set_Assignment_OK (Ref);
8352 -- Deal with untagged derivation of private views
8354 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
8355 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8356 Ref := Unchecked_Convert_To (Utyp, Ref);
8358 -- The following is to prevent problems with UC see 1.156 RH ???
8360 Set_Assignment_OK (Ref);
8361 end if;
8363 -- If the underlying_type is a subtype, then we are dealing with the
8364 -- completion of a private type. We need to access the base type and
8365 -- generate a conversion to it.
8367 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8368 pragma Assert (Is_Private_Type (Typ));
8369 Utyp := Base_Type (Utyp);
8370 Ref := Unchecked_Convert_To (Utyp, Ref);
8371 end if;
8373 -- The underlying type may not be present due to a missing full view.
8374 -- In this case freezing did not take place and there is no suitable
8375 -- [Deep_]Initialize primitive to call.
8377 if No (Utyp) then
8378 return Empty;
8379 end if;
8381 -- Select the appropriate version of initialize
8383 if Has_Controlled_Component (Utyp) then
8384 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
8385 else
8386 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
8387 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
8388 end if;
8390 -- If initialization procedure for an array of controlled objects is
8391 -- trivial, do not generate a useless call to it.
8393 if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
8394 or else
8395 (not Comes_From_Source (Proc)
8396 and then Present (Alias (Proc))
8397 and then Is_Trivial_Subprogram (Alias (Proc)))
8398 then
8399 return Make_Null_Statement (Loc);
8400 end if;
8402 -- The object reference may need another conversion depending on the
8403 -- type of the formal and that of the actual.
8405 Ref := Convert_View (Proc, Ref);
8407 -- Generate:
8408 -- [Deep_]Initialize (Ref);
8410 return
8411 Make_Procedure_Call_Statement (Loc,
8412 Name => New_Occurrence_Of (Proc, Loc),
8413 Parameter_Associations => New_List (Ref));
8414 end Make_Init_Call;
8416 ------------------------------
8417 -- Make_Local_Deep_Finalize --
8418 ------------------------------
8420 function Make_Local_Deep_Finalize
8421 (Typ : Entity_Id;
8422 Nam : Entity_Id) return Node_Id
8424 Loc : constant Source_Ptr := Sloc (Typ);
8425 Formals : List_Id;
8427 begin
8428 Formals := New_List (
8430 -- V : in out Typ
8432 Make_Parameter_Specification (Loc,
8433 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
8434 In_Present => True,
8435 Out_Present => True,
8436 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8438 -- F : Boolean := True
8440 Make_Parameter_Specification (Loc,
8441 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
8442 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
8443 Expression => New_Occurrence_Of (Standard_True, Loc)));
8445 -- Add the necessary number of counters to represent the initialization
8446 -- state of an object.
8448 return
8449 Make_Subprogram_Body (Loc,
8450 Specification =>
8451 Make_Procedure_Specification (Loc,
8452 Defining_Unit_Name => Nam,
8453 Parameter_Specifications => Formals),
8455 Declarations => No_List,
8457 Handled_Statement_Sequence =>
8458 Make_Handled_Sequence_Of_Statements (Loc,
8459 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
8460 end Make_Local_Deep_Finalize;
8462 ------------------------------------
8463 -- Make_Set_Finalize_Address_Call --
8464 ------------------------------------
8466 function Make_Set_Finalize_Address_Call
8467 (Loc : Source_Ptr;
8468 Ptr_Typ : Entity_Id) return Node_Id
8470 -- It is possible for Ptr_Typ to be a partial view, if the access type
8471 -- is a full view declared in the private part of a nested package, and
8472 -- the finalization actions take place when completing analysis of the
8473 -- enclosing unit. For this reason use Underlying_Type twice below.
8475 Desig_Typ : constant Entity_Id :=
8476 Available_View
8477 (Designated_Type (Underlying_Type (Ptr_Typ)));
8478 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
8479 Fin_Mas : constant Entity_Id :=
8480 Finalization_Master (Underlying_Type (Ptr_Typ));
8482 begin
8483 -- Both the finalization master and primitive Finalize_Address must be
8484 -- available.
8486 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
8488 -- Generate:
8489 -- Set_Finalize_Address
8490 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8492 return
8493 Make_Procedure_Call_Statement (Loc,
8494 Name =>
8495 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
8496 Parameter_Associations => New_List (
8497 New_Occurrence_Of (Fin_Mas, Loc),
8499 Make_Attribute_Reference (Loc,
8500 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
8501 Attribute_Name => Name_Unrestricted_Access)));
8502 end Make_Set_Finalize_Address_Call;
8504 --------------------------
8505 -- Make_Transient_Block --
8506 --------------------------
8508 function Make_Transient_Block
8509 (Loc : Source_Ptr;
8510 Action : Node_Id;
8511 Par : Node_Id) return Node_Id
8513 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
8514 -- Determine whether scoping entity Id manages the secondary stack
8516 -----------------------
8517 -- Manages_Sec_Stack --
8518 -----------------------
8520 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
8521 begin
8522 case Ekind (Id) is
8524 -- An exception handler with a choice parameter utilizes a dummy
8525 -- block to provide a declarative region. Such a block should not
8526 -- be considered because it never manifests in the tree and can
8527 -- never release the secondary stack.
8529 when E_Block =>
8530 return
8531 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
8533 when E_Entry
8534 | E_Entry_Family
8535 | E_Function
8536 | E_Procedure
8538 return Uses_Sec_Stack (Id);
8540 when others =>
8541 return False;
8542 end case;
8543 end Manages_Sec_Stack;
8545 -- Local variables
8547 Decls : constant List_Id := New_List;
8548 Instrs : constant List_Id := New_List (Action);
8549 Trans_Id : constant Entity_Id := Current_Scope;
8551 Block : Node_Id;
8552 Insert : Node_Id;
8553 Scop : Entity_Id;
8555 -- Start of processing for Make_Transient_Block
8557 begin
8558 -- Even though the transient block is tasked with managing the secondary
8559 -- stack, the block may forgo this functionality depending on how the
8560 -- secondary stack is managed by enclosing scopes.
8562 if Manages_Sec_Stack (Trans_Id) then
8564 -- Determine whether an enclosing scope already manages the secondary
8565 -- stack.
8567 Scop := Scope (Trans_Id);
8568 while Present (Scop) loop
8570 -- It should not be possible to reach Standard without hitting one
8571 -- of the other cases first unless Standard was manually pushed.
8573 if Scop = Standard_Standard then
8574 exit;
8576 -- The transient block is within a function which returns on the
8577 -- secondary stack. Take a conservative approach and assume that
8578 -- the value on the secondary stack is part of the result. Note
8579 -- that it is not possible to detect this dependency without flow
8580 -- analysis which the compiler does not have. Letting the object
8581 -- live longer than the transient block will not leak any memory
8582 -- because the caller will reclaim the total storage used by the
8583 -- function.
8585 elsif Ekind (Scop) = E_Function
8586 and then Sec_Stack_Needed_For_Return (Scop)
8587 then
8588 Set_Uses_Sec_Stack (Trans_Id, False);
8589 exit;
8591 -- The transient block must manage the secondary stack when the
8592 -- block appears within a loop in order to reclaim the memory at
8593 -- each iteration.
8595 elsif Ekind (Scop) = E_Loop then
8596 exit;
8598 -- The transient block does not need to manage the secondary stack
8599 -- when there is an enclosing construct which already does that.
8600 -- This optimization saves on SS_Mark and SS_Release calls but may
8601 -- allow objects to live a little longer than required.
8603 -- The transient block must manage the secondary stack when switch
8604 -- -gnatd.s (strict management) is in effect.
8606 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
8607 Set_Uses_Sec_Stack (Trans_Id, False);
8608 exit;
8610 -- Prevent the search from going too far because transient blocks
8611 -- are bounded by packages and subprogram scopes.
8613 elsif Ekind_In (Scop, E_Entry,
8614 E_Entry_Family,
8615 E_Function,
8616 E_Package,
8617 E_Procedure,
8618 E_Subprogram_Body)
8619 then
8620 exit;
8621 end if;
8623 Scop := Scope (Scop);
8624 end loop;
8625 end if;
8627 -- Create the transient block. Set the parent now since the block itself
8628 -- is not part of the tree. The current scope is the E_Block entity that
8629 -- has been pushed by Establish_Transient_Scope.
8631 pragma Assert (Ekind (Trans_Id) = E_Block);
8633 Block :=
8634 Make_Block_Statement (Loc,
8635 Identifier => New_Occurrence_Of (Trans_Id, Loc),
8636 Declarations => Decls,
8637 Handled_Statement_Sequence =>
8638 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
8639 Has_Created_Identifier => True);
8640 Set_Parent (Block, Par);
8642 -- Insert actions stuck in the transient scopes as well as all freezing
8643 -- nodes needed by those actions. Do not insert cleanup actions here,
8644 -- they will be transferred to the newly created block.
8646 Insert_Actions_In_Scope_Around
8647 (Action, Clean => False, Manage_SS => False);
8649 Insert := Prev (Action);
8651 if Present (Insert) then
8652 Freeze_All (First_Entity (Trans_Id), Insert);
8653 end if;
8655 -- Transfer cleanup actions to the newly created block
8657 declare
8658 Cleanup_Actions : List_Id
8659 renames Scope_Stack.Table (Scope_Stack.Last).
8660 Actions_To_Be_Wrapped (Cleanup);
8661 begin
8662 Set_Cleanup_Actions (Block, Cleanup_Actions);
8663 Cleanup_Actions := No_List;
8664 end;
8666 -- When the transient scope was established, we pushed the entry for the
8667 -- transient scope onto the scope stack, so that the scope was active
8668 -- for the installation of finalizable entities etc. Now we must remove
8669 -- this entry, since we have constructed a proper block.
8671 Pop_Scope;
8673 return Block;
8674 end Make_Transient_Block;
8676 ------------------------
8677 -- Node_To_Be_Wrapped --
8678 ------------------------
8680 function Node_To_Be_Wrapped return Node_Id is
8681 begin
8682 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
8683 end Node_To_Be_Wrapped;
8685 ----------------------------
8686 -- Set_Node_To_Be_Wrapped --
8687 ----------------------------
8689 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
8690 begin
8691 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
8692 end Set_Node_To_Be_Wrapped;
8694 ----------------------------
8695 -- Store_Actions_In_Scope --
8696 ----------------------------
8698 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
8699 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
8700 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
8702 begin
8703 if No (Actions) then
8704 Actions := L;
8706 if Is_List_Member (SE.Node_To_Be_Wrapped) then
8707 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
8708 else
8709 Set_Parent (L, SE.Node_To_Be_Wrapped);
8710 end if;
8712 Analyze_List (L);
8714 elsif AK = Before then
8715 Insert_List_After_And_Analyze (Last (Actions), L);
8717 else
8718 Insert_List_Before_And_Analyze (First (Actions), L);
8719 end if;
8720 end Store_Actions_In_Scope;
8722 ----------------------------------
8723 -- Store_After_Actions_In_Scope --
8724 ----------------------------------
8726 procedure Store_After_Actions_In_Scope (L : List_Id) is
8727 begin
8728 Store_Actions_In_Scope (After, L);
8729 end Store_After_Actions_In_Scope;
8731 -----------------------------------
8732 -- Store_Before_Actions_In_Scope --
8733 -----------------------------------
8735 procedure Store_Before_Actions_In_Scope (L : List_Id) is
8736 begin
8737 Store_Actions_In_Scope (Before, L);
8738 end Store_Before_Actions_In_Scope;
8740 -----------------------------------
8741 -- Store_Cleanup_Actions_In_Scope --
8742 -----------------------------------
8744 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
8745 begin
8746 Store_Actions_In_Scope (Cleanup, L);
8747 end Store_Cleanup_Actions_In_Scope;
8749 --------------------------------
8750 -- Wrap_Transient_Declaration --
8751 --------------------------------
8753 -- If a transient scope has been established during the processing of the
8754 -- Expression of an Object_Declaration, it is not possible to wrap the
8755 -- declaration into a transient block as usual case, otherwise the object
8756 -- would be itself declared in the wrong scope. Therefore, all entities (if
8757 -- any) defined in the transient block are moved to the proper enclosing
8758 -- scope. Furthermore, if they are controlled variables they are finalized
8759 -- right after the declaration. The finalization list of the transient
8760 -- scope is defined as a renaming of the enclosing one so during their
8761 -- initialization they will be attached to the proper finalization list.
8762 -- For instance, the following declaration :
8764 -- X : Typ := F (G (A), G (B));
8766 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8767 -- is expanded into :
8769 -- X : Typ := [ complex Expression-Action ];
8770 -- [Deep_]Finalize (_v1);
8771 -- [Deep_]Finalize (_v2);
8773 procedure Wrap_Transient_Declaration (N : Node_Id) is
8774 Curr_S : Entity_Id;
8775 Encl_S : Entity_Id;
8777 begin
8778 Curr_S := Current_Scope;
8779 Encl_S := Scope (Curr_S);
8781 -- Insert all actions including cleanup generated while analyzing or
8782 -- expanding the transient context back into the tree. Manage the
8783 -- secondary stack when the object declaration appears in a library
8784 -- level package [body].
8786 Insert_Actions_In_Scope_Around
8787 (N => N,
8788 Clean => True,
8789 Manage_SS =>
8790 Uses_Sec_Stack (Curr_S)
8791 and then Nkind (N) = N_Object_Declaration
8792 and then Ekind_In (Encl_S, E_Package, E_Package_Body)
8793 and then Is_Library_Level_Entity (Encl_S));
8794 Pop_Scope;
8796 -- Relocate local entities declared within the transient scope to the
8797 -- enclosing scope. This action sets their Is_Public flag accordingly.
8799 Transfer_Entities (Curr_S, Encl_S);
8801 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8802 -- is properly released upon exiting the said scope.
8804 if Uses_Sec_Stack (Curr_S) then
8805 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
8807 -- Do not mark a function that returns on the secondary stack as the
8808 -- reclamation is done by the caller.
8810 if Ekind (Curr_S) = E_Function
8811 and then Requires_Transient_Scope (Etype (Curr_S))
8812 then
8813 null;
8815 -- Otherwise mark the enclosing dynamic scope
8817 else
8818 Set_Uses_Sec_Stack (Curr_S);
8819 Check_Restriction (No_Secondary_Stack, N);
8820 end if;
8821 end if;
8822 end Wrap_Transient_Declaration;
8824 -------------------------------
8825 -- Wrap_Transient_Expression --
8826 -------------------------------
8828 procedure Wrap_Transient_Expression (N : Node_Id) is
8829 Loc : constant Source_Ptr := Sloc (N);
8830 Expr : Node_Id := Relocate_Node (N);
8831 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
8832 Typ : constant Entity_Id := Etype (N);
8834 begin
8835 -- Generate:
8837 -- Temp : Typ;
8838 -- declare
8839 -- M : constant Mark_Id := SS_Mark;
8840 -- procedure Finalizer is ... (See Build_Finalizer)
8842 -- begin
8843 -- Temp := <Expr>; -- general case
8844 -- Temp := (if <Expr> then True else False); -- boolean case
8846 -- at end
8847 -- Finalizer;
8848 -- end;
8850 -- A special case is made for Boolean expressions so that the back end
8851 -- knows to generate a conditional branch instruction, if running with
8852 -- -fpreserve-control-flow. This ensures that a control-flow change
8853 -- signaling the decision outcome occurs before the cleanup actions.
8855 if Opt.Suppress_Control_Flow_Optimizations
8856 and then Is_Boolean_Type (Typ)
8857 then
8858 Expr :=
8859 Make_If_Expression (Loc,
8860 Expressions => New_List (
8861 Expr,
8862 New_Occurrence_Of (Standard_True, Loc),
8863 New_Occurrence_Of (Standard_False, Loc)));
8864 end if;
8866 Insert_Actions (N, New_List (
8867 Make_Object_Declaration (Loc,
8868 Defining_Identifier => Temp,
8869 Object_Definition => New_Occurrence_Of (Typ, Loc)),
8871 Make_Transient_Block (Loc,
8872 Action =>
8873 Make_Assignment_Statement (Loc,
8874 Name => New_Occurrence_Of (Temp, Loc),
8875 Expression => Expr),
8876 Par => Parent (N))));
8878 Rewrite (N, New_Occurrence_Of (Temp, Loc));
8879 Analyze_And_Resolve (N, Typ);
8880 end Wrap_Transient_Expression;
8882 ------------------------------
8883 -- Wrap_Transient_Statement --
8884 ------------------------------
8886 procedure Wrap_Transient_Statement (N : Node_Id) is
8887 Loc : constant Source_Ptr := Sloc (N);
8888 New_Stmt : constant Node_Id := Relocate_Node (N);
8890 begin
8891 -- Generate:
8892 -- declare
8893 -- M : constant Mark_Id := SS_Mark;
8894 -- procedure Finalizer is ... (See Build_Finalizer)
8896 -- begin
8897 -- <New_Stmt>;
8899 -- at end
8900 -- Finalizer;
8901 -- end;
8903 Rewrite (N,
8904 Make_Transient_Block (Loc,
8905 Action => New_Stmt,
8906 Par => Parent (N)));
8908 -- With the scope stack back to normal, we can call analyze on the
8909 -- resulting block. At this point, the transient scope is being
8910 -- treated like a perfectly normal scope, so there is nothing
8911 -- special about it.
8913 -- Note: Wrap_Transient_Statement is called with the node already
8914 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8915 -- otherwise we would get a recursive processing of the node when
8916 -- we do this Analyze call.
8918 Analyze (N);
8919 end Wrap_Transient_Statement;
8921 end Exp_Ch7;