File : exp_ch7.adb
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-2016, 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 ------------------------------------------------------------------------------
25
26 -- This package contains virtually all expansion mechanisms related to
27 -- - controlled types
28 -- - transient scopes
29
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 Ghost; use Ghost;
46 with Lib; use Lib;
47 with Nlists; use Nlists;
48 with Nmake; use Nmake;
49 with Opt; use Opt;
50 with Output; use Output;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
54 with Sinfo; use Sinfo;
55 with Sem; use Sem;
56 with Sem_Aux; use Sem_Aux;
57 with Sem_Ch3; use Sem_Ch3;
58 with Sem_Ch6; use Sem_Ch6;
59 with Sem_Ch7; use Sem_Ch7;
60 with Sem_Ch8; use Sem_Ch8;
61 with Sem_Ch13; use Sem_Ch13;
62 with Sem_Res; use Sem_Res;
63 with Sem_Util; use Sem_Util;
64 with Snames; use Snames;
65 with Stand; use Stand;
66 with Stringt; use Stringt;
67 with Tbuild; use Tbuild;
68 with Ttypes; use Ttypes;
69 with Uintp; use Uintp;
70
71 package body Exp_Ch7 is
72
73 --------------------------------
74 -- Transient Scope Management --
75 --------------------------------
76
77 -- A transient scope is created when temporary objects are created by the
78 -- compiler. These temporary objects are allocated on the secondary stack
79 -- and the transient scope is responsible for finalizing the object when
80 -- appropriate and reclaiming the memory at the right time. The temporary
81 -- objects are generally the objects allocated to store the result of a
82 -- function returning an unconstrained or a tagged value. Expressions
83 -- needing to be wrapped in a transient scope (functions calls returning
84 -- unconstrained or tagged values) may appear in 3 different contexts which
85 -- lead to 3 different kinds of transient scope expansion:
86
87 -- 1. In a simple statement (procedure call, assignment, ...). In this
88 -- case the instruction is wrapped into a transient block. See
89 -- Wrap_Transient_Statement for details.
90
91 -- 2. In an expression of a control structure (test in a IF statement,
92 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
93 -- for details.
94
95 -- 3. In a expression of an object_declaration. No wrapping is possible
96 -- here, so the finalization actions, if any, are done right after the
97 -- declaration and the secondary stack deallocation is done in the
98 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
99
100 -- Note about functions returning tagged types: it has been decided to
101 -- always allocate their result in the secondary stack, even though is not
102 -- absolutely mandatory when the tagged type is constrained because the
103 -- caller knows the size of the returned object and thus could allocate the
104 -- result in the primary stack. An exception to this is when the function
105 -- builds its result in place, as is done for functions with inherently
106 -- limited result types for Ada 2005. In that case, certain callers may
107 -- pass the address of a constrained object as the target object for the
108 -- function result.
109
110 -- By allocating tagged results in the secondary stack a number of
111 -- implementation difficulties are avoided:
112
113 -- - If it is a dispatching function call, the computation of the size of
114 -- the result is possible but complex from the outside.
115
116 -- - If the returned type is controlled, the assignment of the returned
117 -- value to the anonymous object involves an Adjust, and we have no
118 -- easy way to access the anonymous object created by the back end.
119
120 -- - If the returned type is class-wide, this is an unconstrained type
121 -- anyway.
122
123 -- Furthermore, the small loss in efficiency which is the result of this
124 -- decision is not such a big deal because functions returning tagged types
125 -- are not as common in practice compared to functions returning access to
126 -- a tagged type.
127
128 --------------------------------------------------
129 -- Transient Blocks and Finalization Management --
130 --------------------------------------------------
131
132 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
133 -- N is a node which may generate a transient scope. Loop over the parent
134 -- pointers of N until we find the appropriate node to wrap. If it returns
135 -- Empty, it means that no transient scope is needed in this context.
136
137 procedure Insert_Actions_In_Scope_Around
138 (N : Node_Id;
139 Clean : Boolean;
140 Manage_SS : Boolean);
141 -- Insert the before-actions kept in the scope stack before N, and the
142 -- after-actions after N, which must be a member of a list. If flag Clean
143 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
144 -- calls to mark and release the secondary stack.
145
146 function Make_Transient_Block
147 (Loc : Source_Ptr;
148 Action : Node_Id;
149 Par : Node_Id) return Node_Id;
150 -- Action is a single statement or object declaration. Par is the proper
151 -- parent of the generated block. Create a transient block whose name is
152 -- the current scope and the only handled statement is Action. If Action
153 -- involves controlled objects or secondary stack usage, the corresponding
154 -- cleanup actions are performed at the end of the block.
155
156 procedure Set_Node_To_Be_Wrapped (N : Node_Id);
157 -- Set the field Node_To_Be_Wrapped of the current scope
158
159 -- ??? The entire comment needs to be rewritten
160 -- ??? which entire comment?
161
162 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
163 -- Shared processing for Store_xxx_Actions_In_Scope
164
165 -----------------------------
166 -- Finalization Management --
167 -----------------------------
168
169 -- This part describe how Initialization/Adjustment/Finalization procedures
170 -- are generated and called. Two cases must be considered, types that are
171 -- Controlled (Is_Controlled flag set) and composite types that contain
172 -- controlled components (Has_Controlled_Component flag set). In the first
173 -- case the procedures to call are the user-defined primitive operations
174 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
175 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
176 -- of calling the former procedures on the controlled components.
177
178 -- For records with Has_Controlled_Component set, a hidden "controller"
179 -- component is inserted. This controller component contains its own
180 -- finalization list on which all controlled components are attached
181 -- creating an indirection on the upper-level Finalization list. This
182 -- technique facilitates the management of objects whose number of
183 -- controlled components changes during execution. This controller
184 -- component is itself controlled and is attached to the upper-level
185 -- finalization chain. Its adjust primitive is in charge of calling adjust
186 -- on the components and adjusting the finalization pointer to match their
187 -- new location (see a-finali.adb).
188
189 -- It is not possible to use a similar technique for arrays that have
190 -- Has_Controlled_Component set. In this case, deep procedures are
191 -- generated that call initialize/adjust/finalize + attachment or
192 -- detachment on the finalization list for all component.
193
194 -- Initialize calls: they are generated for declarations or dynamic
195 -- allocations of Controlled objects with no initial value. They are always
196 -- followed by an attachment to the current Finalization Chain. For the
197 -- dynamic allocation case this the chain attached to the scope of the
198 -- access type definition otherwise, this is the chain of the current
199 -- scope.
200
201 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
202 -- or dynamic allocations of Controlled objects with an initial value.
203 -- (2) after an assignment. In the first case they are followed by an
204 -- attachment to the final chain, in the second case they are not.
205
206 -- Finalization Calls: They are generated on (1) scope exit, (2)
207 -- assignments, (3) unchecked deallocations. In case (3) they have to
208 -- be detached from the final chain, in case (2) they must not and in
209 -- case (1) this is not important since we are exiting the scope anyway.
210
211 -- Other details:
212
213 -- Type extensions will have a new record controller at each derivation
214 -- level containing controlled components. The record controller for
215 -- the parent/ancestor is attached to the finalization list of the
216 -- extension's record controller (i.e. the parent is like a component
217 -- of the extension).
218
219 -- For types that are both Is_Controlled and Has_Controlled_Components,
220 -- the record controller and the object itself are handled separately.
221 -- It could seem simpler to attach the object at the end of its record
222 -- controller but this would not tackle view conversions properly.
223
224 -- A classwide type can always potentially have controlled components
225 -- but the record controller of the corresponding actual type may not
226 -- be known at compile time so the dispatch table contains a special
227 -- field that allows computation of the offset of the record controller
228 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
229
230 -- Here is a simple example of the expansion of a controlled block :
231
232 -- declare
233 -- X : Controlled;
234 -- Y : Controlled := Init;
235 --
236 -- type R is record
237 -- C : Controlled;
238 -- end record;
239 -- W : R;
240 -- Z : R := (C => X);
241
242 -- begin
243 -- X := Y;
244 -- W := Z;
245 -- end;
246 --
247 -- is expanded into
248 --
249 -- declare
250 -- _L : System.FI.Finalizable_Ptr;
251
252 -- procedure _Clean is
253 -- begin
254 -- Abort_Defer;
255 -- System.FI.Finalize_List (_L);
256 -- Abort_Undefer;
257 -- end _Clean;
258
259 -- X : Controlled;
260 -- begin
261 -- Abort_Defer;
262 -- Initialize (X);
263 -- Attach_To_Final_List (_L, Finalizable (X), 1);
264 -- at end: Abort_Undefer;
265 -- Y : Controlled := Init;
266 -- Adjust (Y);
267 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
268 --
269 -- type R is record
270 -- C : Controlled;
271 -- end record;
272 -- W : R;
273 -- begin
274 -- Abort_Defer;
275 -- Deep_Initialize (W, _L, 1);
276 -- at end: Abort_Under;
277 -- Z : R := (C => X);
278 -- Deep_Adjust (Z, _L, 1);
279
280 -- begin
281 -- _Assign (X, Y);
282 -- Deep_Finalize (W, False);
283 -- <save W's final pointers>
284 -- W := Z;
285 -- <restore W's final pointers>
286 -- Deep_Adjust (W, _L, 0);
287 -- at end
288 -- _Clean;
289 -- end;
290
291 type Final_Primitives is
292 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
293 -- This enumeration type is defined in order to ease sharing code for
294 -- building finalization procedures for composite types.
295
296 Name_Of : constant array (Final_Primitives) of Name_Id :=
297 (Initialize_Case => Name_Initialize,
298 Adjust_Case => Name_Adjust,
299 Finalize_Case => Name_Finalize,
300 Address_Case => Name_Finalize_Address);
301 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
302 (Initialize_Case => TSS_Deep_Initialize,
303 Adjust_Case => TSS_Deep_Adjust,
304 Finalize_Case => TSS_Deep_Finalize,
305 Address_Case => TSS_Finalize_Address);
306
307 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
308 -- Determine whether access type Typ may have a finalization master
309
310 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
311 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
312 -- Has_Controlled_Component set and store them using the TSS mechanism.
313
314 function Build_Cleanup_Statements
315 (N : Node_Id;
316 Additional_Cleanup : List_Id) return List_Id;
317 -- Create the clean up calls for an asynchronous call block, task master,
318 -- protected subprogram body, task allocation block or task body, or
319 -- additional cleanup actions parked on a transient block. If the context
320 -- does not contain the above constructs, the routine returns an empty
321 -- list.
322
323 procedure Build_Finalizer
324 (N : Node_Id;
325 Clean_Stmts : List_Id;
326 Mark_Id : Entity_Id;
327 Top_Decls : List_Id;
328 Defer_Abort : Boolean;
329 Fin_Id : out Entity_Id);
330 -- N may denote an accept statement, block, entry body, package body,
331 -- package spec, protected body, subprogram body, or a task body. Create
332 -- a procedure which contains finalization calls for all controlled objects
333 -- declared in the declarative or statement region of N. The calls are
334 -- built in reverse order relative to the original declarations. In the
335 -- case of a task body, the routine delays the creation of the finalizer
336 -- until all statements have been moved to the task body procedure.
337 -- Clean_Stmts may contain additional context-dependent code used to abort
338 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
339 -- Mark_Id is the secondary stack used in the current context or Empty if
340 -- missing. Top_Decls is the list on which the declaration of the finalizer
341 -- is attached in the non-package case. Defer_Abort indicates that the
342 -- statements passed in perform actions that require abort to be deferred,
343 -- such as for task termination. Fin_Id is the finalizer declaration
344 -- entity.
345
346 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
347 -- N is a construct which contains a handled sequence of statements, Fin_Id
348 -- is the entity of a finalizer. Create an At_End handler which covers the
349 -- statements of N and calls Fin_Id. If the handled statement sequence has
350 -- an exception handler, the statements will be wrapped in a block to avoid
351 -- unwanted interaction with the new At_End handler.
352
353 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
354 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
355 -- Has_Component_Component set and store them using the TSS mechanism.
356
357 procedure Check_Visibly_Controlled
358 (Prim : Final_Primitives;
359 Typ : Entity_Id;
360 E : in out Entity_Id;
361 Cref : in out Node_Id);
362 -- The controlled operation declared for a derived type may not be
363 -- overriding, if the controlled operations of the parent type are hidden,
364 -- for example when the parent is a private type whose full view is
365 -- controlled. For other primitive operations we modify the name of the
366 -- operation to indicate that it is not overriding, but this is not
367 -- possible for Initialize, etc. because they have to be retrievable by
368 -- name. Before generating the proper call to one of these operations we
369 -- check whether Typ is known to be controlled at the point of definition.
370 -- If it is not then we must retrieve the hidden operation of the parent
371 -- and use it instead. This is one case that might be solved more cleanly
372 -- once Overriding pragmas or declarations are in place.
373
374 function Convert_View
375 (Proc : Entity_Id;
376 Arg : Node_Id;
377 Ind : Pos := 1) return Node_Id;
378 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
379 -- argument being passed to it. Ind indicates which formal of procedure
380 -- Proc we are trying to match. This function will, if necessary, generate
381 -- a conversion between the partial and full view of Arg to match the type
382 -- of the formal of Proc, or force a conversion to the class-wide type in
383 -- the case where the operation is abstract.
384
385 function Enclosing_Function (E : Entity_Id) return Entity_Id;
386 -- Given an arbitrary entity, traverse the scope chain looking for the
387 -- first enclosing function. Return Empty if no function was found.
388
389 function Make_Call
390 (Loc : Source_Ptr;
391 Proc_Id : Entity_Id;
392 Param : Node_Id;
393 Skip_Self : Boolean := False) return Node_Id;
394 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
395 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
396 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
397 -- action has an effect on the components only (if any).
398
399 function Make_Deep_Proc
400 (Prim : Final_Primitives;
401 Typ : Entity_Id;
402 Stmts : List_Id) return Node_Id;
403 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
404 -- Deep_Finalize procedures according to the first parameter, these
405 -- procedures operate on the type Typ. The Stmts parameter gives the body
406 -- of the procedure.
407
408 function Make_Deep_Array_Body
409 (Prim : Final_Primitives;
410 Typ : Entity_Id) return List_Id;
411 -- This function generates the list of statements for implementing
412 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
413 -- the first parameter, these procedures operate on the array type Typ.
414
415 function Make_Deep_Record_Body
416 (Prim : Final_Primitives;
417 Typ : Entity_Id;
418 Is_Local : Boolean := False) return List_Id;
419 -- This function generates the list of statements for implementing
420 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
421 -- the first parameter, these procedures operate on the record type Typ.
422 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
423 -- whether the inner logic should be dictated by state counters.
424
425 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
426 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
427 -- Make_Deep_Record_Body. Generate the following statements:
428 --
429 -- declare
430 -- type Acc_Typ is access all Typ;
431 -- for Acc_Typ'Storage_Size use 0;
432 -- begin
433 -- [Deep_]Finalize (Acc_Typ (V).all);
434 -- end;
435
436 --------------------------------
437 -- Allows_Finalization_Master --
438 --------------------------------
439
440 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
441 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
442 -- Determine whether entity E is inside a wrapper package created for
443 -- an instance of Ada.Unchecked_Deallocation.
444
445 ------------------------------
446 -- In_Deallocation_Instance --
447 ------------------------------
448
449 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
450 Pkg : constant Entity_Id := Scope (E);
451 Par : Node_Id := Empty;
452
453 begin
454 if Ekind (Pkg) = E_Package
455 and then Present (Related_Instance (Pkg))
456 and then Ekind (Related_Instance (Pkg)) = E_Procedure
457 then
458 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
459
460 return
461 Present (Par)
462 and then Chars (Par) = Name_Unchecked_Deallocation
463 and then Chars (Scope (Par)) = Name_Ada
464 and then Scope (Scope (Par)) = Standard_Standard;
465 end if;
466
467 return False;
468 end In_Deallocation_Instance;
469
470 -- Local variables
471
472 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
473 Ptr_Typ : constant Entity_Id :=
474 Root_Type_Of_Full_View (Base_Type (Typ));
475
476 -- Start of processing for Allows_Finalization_Master
477
478 begin
479 -- Certain run-time configurations and targets do not provide support
480 -- for controlled types and therefore do not need masters.
481
482 if Restriction_Active (No_Finalization) then
483 return False;
484
485 -- Do not consider C and C++ types since it is assumed that the non-Ada
486 -- side will handle their clean up.
487
488 elsif Convention (Desig_Typ) = Convention_C
489 or else Convention (Desig_Typ) = Convention_CPP
490 then
491 return False;
492
493 -- Do not consider types that return on the secondary stack
494
495 elsif Present (Associated_Storage_Pool (Ptr_Typ))
496 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
497 then
498 return False;
499
500 -- Do not consider types which may never allocate an object
501
502 elsif No_Pool_Assigned (Ptr_Typ) then
503 return False;
504
505 -- Do not consider access types coming from Ada.Unchecked_Deallocation
506 -- instances. Even though the designated type may be controlled, the
507 -- access type will never participate in allocation.
508
509 elsif In_Deallocation_Instance (Ptr_Typ) then
510 return False;
511
512 -- Do not consider non-library access types when restriction
513 -- No_Nested_Finalization is in effect since masters are controlled
514 -- objects.
515
516 elsif Restriction_Active (No_Nested_Finalization)
517 and then not Is_Library_Level_Entity (Ptr_Typ)
518 then
519 return False;
520
521 -- Do not create finalization masters in GNATprove mode because this
522 -- causes unwanted extra expansion. A compilation in this mode must
523 -- keep the tree as close as possible to the original sources.
524
525 elsif GNATprove_Mode then
526 return False;
527
528 -- Otherwise the access type may use a finalization master
529
530 else
531 return True;
532 end if;
533 end Allows_Finalization_Master;
534
535 ----------------------------
536 -- Build_Anonymous_Master --
537 ----------------------------
538
539 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
540 function Create_Anonymous_Master
541 (Desig_Typ : Entity_Id;
542 Unit_Id : Entity_Id;
543 Unit_Decl : Node_Id) return Entity_Id;
544 -- Create a new anonymous finalization master for access type Ptr_Typ
545 -- with designated type Desig_Typ. The declaration of the master along
546 -- with its specialized initialization is inserted in the declarative
547 -- part of unit Unit_Decl. Unit_Id denotes the entity of Unit_Decl.
548
549 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean;
550 -- Determine whether arbitrary node N appears within the subtree rooted
551 -- at node Root.
552
553 -----------------------------
554 -- Create_Anonymous_Master --
555 -----------------------------
556
557 function Create_Anonymous_Master
558 (Desig_Typ : Entity_Id;
559 Unit_Id : Entity_Id;
560 Unit_Decl : Node_Id) return Entity_Id
561 is
562 Loc : constant Source_Ptr := Sloc (Unit_Id);
563 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
564 Decls : List_Id;
565 FM_Decl : Node_Id;
566 FM_Id : Entity_Id;
567 FM_Init : Node_Id;
568 Pref : Character;
569 Unit_Spec : Node_Id;
570
571 begin
572 -- Find the declarative list of the unit
573
574 if Nkind (Unit_Decl) = N_Package_Declaration then
575 Unit_Spec := Specification (Unit_Decl);
576 Decls := Visible_Declarations (Unit_Spec);
577
578 if No (Decls) then
579 Decls := New_List;
580 Set_Visible_Declarations (Unit_Spec, Decls);
581 end if;
582
583 -- Package body or subprogram case
584
585 -- ??? A subprogram spec or body that acts as a compilation unit may
586 -- contain a formal parameter of an anonymous access-to-controlled
587 -- type initialized by an allocator.
588
589 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
590
591 -- There is no suitable place to create the anonymous master as the
592 -- subprogram is not in a declarative list.
593
594 else
595 Decls := Declarations (Unit_Decl);
596
597 if No (Decls) then
598 Decls := New_List;
599 Set_Declarations (Unit_Decl, Decls);
600 end if;
601 end if;
602
603 -- Step 1: Anonymous master creation
604
605 -- Use a unique prefix in case the same unit requires two anonymous
606 -- masters, one for the spec (S) and one for the body (B).
607
608 if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
609 Pref := 'S';
610 else
611 Pref := 'B';
612 end if;
613
614 -- The name of the anonymous master has the following format:
615
616 -- [BS]scopN__scop1__chars_of_desig_typAM
617
618 -- The name utilizes the fully qualified name of the designated type
619 -- in case two controlled types with the same name are declared in
620 -- different scopes and both have anonymous access types.
621
622 FM_Id :=
623 Make_Defining_Identifier (Loc,
624 New_External_Name
625 (Related_Id => Get_Qualified_Name (Desig_Typ),
626 Suffix => "AM",
627 Prefix => Pref));
628
629 -- Associate the anonymous master with the designated type. This
630 -- ensures that any additional anonymous access types with the same
631 -- designated type will share the same anonymous master within the
632 -- same unit.
633
634 Set_Anonymous_Master (Desig_Typ, FM_Id);
635
636 -- Generate:
637 -- <FM_Id> : Finalization_Master;
638
639 FM_Decl :=
640 Make_Object_Declaration (Loc,
641 Defining_Identifier => FM_Id,
642 Object_Definition =>
643 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
644
645 -- Step 2: Initialization actions
646
647 -- Generate:
648 -- Set_Base_Pool
649 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
650
651 FM_Init :=
652 Make_Procedure_Call_Statement (Loc,
653 Name =>
654 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
655 Parameter_Associations => New_List (
656 New_Occurrence_Of (FM_Id, Loc),
657 Make_Attribute_Reference (Loc,
658 Prefix =>
659 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
660 Attribute_Name => Name_Unrestricted_Access)));
661
662 Prepend_To (Decls, FM_Init);
663 Prepend_To (Decls, FM_Decl);
664
665 -- Since the anonymous master and all its initialization actions are
666 -- inserted at top level, use the scope of the unit when analyzing.
667
668 Push_Scope (Spec_Id);
669 Analyze (FM_Decl);
670 Analyze (FM_Init);
671 Pop_Scope;
672
673 return FM_Id;
674 end Create_Anonymous_Master;
675
676 ----------------
677 -- In_Subtree --
678 ----------------
679
680 function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
681 Par : Node_Id;
682
683 begin
684 -- Traverse the parent chain until reaching the same root
685
686 Par := N;
687 while Present (Par) loop
688 if Par = Root then
689 return True;
690 end if;
691
692 Par := Parent (Par);
693 end loop;
694
695 return False;
696 end In_Subtree;
697
698 -- Local variables
699
700 Desig_Typ : Entity_Id;
701 FM_Id : Entity_Id;
702 Priv_View : Entity_Id;
703 Unit_Decl : Node_Id;
704 Unit_Id : Entity_Id;
705
706 -- Start of processing for Build_Anonymous_Master
707
708 begin
709 -- Nothing to do if the circumstances do not allow for a finalization
710 -- master.
711
712 if not Allows_Finalization_Master (Ptr_Typ) then
713 return;
714 end if;
715
716 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
717 Unit_Id := Defining_Entity (Unit_Decl);
718
719 -- The compilation unit is a package instantiation. In this case the
720 -- anonymous master is associated with the package spec as both the
721 -- spec and body appear at the same level.
722
723 if Nkind (Unit_Decl) = N_Package_Body
724 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
725 then
726 Unit_Id := Corresponding_Spec (Unit_Decl);
727 Unit_Decl := Unit_Declaration_Node (Unit_Id);
728 end if;
729
730 -- Use the initial declaration of the designated type when it denotes
731 -- the full view of an incomplete or private type. This ensures that
732 -- types with one and two views are treated the same.
733
734 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
735 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
736
737 if Present (Priv_View) then
738 Desig_Typ := Priv_View;
739 end if;
740
741 FM_Id := Anonymous_Master (Desig_Typ);
742
743 -- The designated type already has at least one anonymous access type
744 -- pointing to it within the current unit. Reuse the anonymous master
745 -- because the designated type is the same.
746
747 if Present (FM_Id)
748 and then In_Subtree (Declaration_Node (FM_Id), Root => Unit_Decl)
749 then
750 null;
751
752 -- Otherwise the designated type lacks an anonymous master or it is
753 -- declared in a different unit. Create a brand new master.
754
755 else
756 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
757 end if;
758
759 Set_Finalization_Master (Ptr_Typ, FM_Id);
760 end Build_Anonymous_Master;
761
762 ----------------------------
763 -- Build_Array_Deep_Procs --
764 ----------------------------
765
766 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
767 begin
768 Set_TSS (Typ,
769 Make_Deep_Proc
770 (Prim => Initialize_Case,
771 Typ => Typ,
772 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
773
774 if not Is_Limited_View (Typ) then
775 Set_TSS (Typ,
776 Make_Deep_Proc
777 (Prim => Adjust_Case,
778 Typ => Typ,
779 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
780 end if;
781
782 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
783 -- suppressed since these routine will not be used.
784
785 if not Restriction_Active (No_Finalization) then
786 Set_TSS (Typ,
787 Make_Deep_Proc
788 (Prim => Finalize_Case,
789 Typ => Typ,
790 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
791
792 -- Create TSS primitive Finalize_Address.
793
794 Set_TSS (Typ,
795 Make_Deep_Proc
796 (Prim => Address_Case,
797 Typ => Typ,
798 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
799 end if;
800 end Build_Array_Deep_Procs;
801
802 ------------------------------
803 -- Build_Cleanup_Statements --
804 ------------------------------
805
806 function Build_Cleanup_Statements
807 (N : Node_Id;
808 Additional_Cleanup : List_Id) return List_Id
809 is
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;
824
825 Loc : constant Source_Ptr := Sloc (N);
826 Stmts : constant List_Id := New_List;
827
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;
836
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;
841
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.
845
846 -- NOTE: The generated code references _object, a parameter to the
847 -- procedure.
848
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;
855
856 begin
857 -- Find the _object parameter representing the protected object
858
859 Param := First (Parameter_Specifications (Spec));
860 loop
861 Param_Typ := Etype (Parameter_Type (Param));
862
863 if Ekind (Param_Typ) = E_Record_Type then
864 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
865 end if;
866
867 exit when No (Param) or else Present (Conc_Typ);
868 Next (Param);
869 end loop;
870
871 pragma Assert (Present (Param));
872
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.
876
877 Build_Protected_Subprogram_Call_Cleanup
878 (Specification (N), Conc_Typ, Loc, Stmts);
879 end;
880
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.
884
885 -- NOTE: The generated code references _chain, a local object
886
887 elsif Is_Task_Allocation then
888
889 -- Generate:
890 -- Expunge_Unactivated_Tasks (_chain);
891
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.
895
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))));
903
904 -- Attempt to cancel an asynchronous entry call whenever the block which
905 -- contains the abortable part is exited.
906
907 -- NOTE: The generated code references Cnn, a local object
908
909 elsif Is_Asynchronous_Call then
910 declare
911 Cancel_Param : constant Entity_Id :=
912 Entry_Cancel_Parameter (Entity (Identifier (N)));
913
914 begin
915 -- If it is of type Communication_Block, this must be a protected
916 -- entry call. Generate:
917
918 -- if Enqueued (Cancel_Param) then
919 -- Cancel_Protected_Entry_Call (Cancel_Param);
920 -- end if;
921
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))),
931
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))))));
939
940 -- Asynchronous delay, generate:
941 -- Cancel_Async_Delay (Cancel_Param);
942
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))));
953
954 -- Task entry call, generate:
955 -- Cancel_Task_Entry_Call (Cancel_Param);
956
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;
967
968 Append_List_To (Stmts, Additional_Cleanup);
969 return Stmts;
970 end Build_Cleanup_Statements;
971
972 -----------------------------
973 -- Build_Controlling_Procs --
974 -----------------------------
975
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;
984
985 -----------------------------
986 -- Build_Exception_Handler --
987 -----------------------------
988
989 function Build_Exception_Handler
990 (Data : Finalization_Exception_Data;
991 For_Library : Boolean := False) return Node_Id
992 is
993 Actuals : List_Id;
994 Proc_To_Call : Entity_Id;
995 Except : Node_Id;
996 Stmts : List_Id;
997
998 begin
999 pragma Assert (Present (Data.Raised_Id));
1000
1001 if Exception_Extra_Info
1002 or else (For_Library and not Restricted_Profile)
1003 then
1004 if Exception_Extra_Info then
1005
1006 -- Generate:
1007
1008 -- Get_Current_Excep.all
1009
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)));
1017
1018 else
1019 -- Generate:
1020
1021 -- null
1022
1023 Except := Make_Null (Data.Loc);
1024 end if;
1025
1026 if For_Library and then not Restricted_Profile then
1027 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1028 Actuals := New_List (Except);
1029
1030 else
1031 Proc_To_Call := RTE (RE_Save_Occurrence);
1032
1033 -- The dereference occurs only when Exception_Extra_Info is true,
1034 -- and therefore Except is not null.
1035
1036 Actuals :=
1037 New_List (
1038 New_Occurrence_Of (Data.E_Id, Data.Loc),
1039 Make_Explicit_Dereference (Data.Loc, Except));
1040 end if;
1041
1042 -- Generate:
1043
1044 -- when others =>
1045 -- if not Raised_Id then
1046 -- Raised_Id := True;
1047
1048 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1049 -- or
1050 -- Save_Library_Occurrence (Get_Current_Excep.all);
1051 -- end if;
1052
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)),
1059
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)),
1064
1065 Make_Procedure_Call_Statement (Data.Loc,
1066 Name =>
1067 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1068 Parameter_Associations => Actuals))));
1069
1070 else
1071 -- Generate:
1072
1073 -- Raised_Id := True;
1074
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;
1080
1081 -- Generate:
1082
1083 -- when others =>
1084
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;
1090
1091 -------------------------------
1092 -- Build_Finalization_Master --
1093 -------------------------------
1094
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)
1101 is
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
1106
1107 -----------------------------
1108 -- Add_Pending_Access_Type --
1109 -----------------------------
1110
1111 procedure Add_Pending_Access_Type
1112 (Typ : Entity_Id;
1113 Ptr_Typ : Entity_Id)
1114 is
1115 List : Elist_Id;
1116
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;
1124
1125 Prepend_Elmt (Ptr_Typ, List);
1126 end Add_Pending_Access_Type;
1127
1128 -- Local variables
1129
1130 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1131
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.
1137
1138 -- Start of processing for Build_Finalization_Master
1139
1140 begin
1141 -- Nothing to do if the circumstances do not allow for a finalization
1142 -- master.
1143
1144 if not Allows_Finalization_Master (Typ) then
1145 return;
1146
1147 -- Various machinery such as freezing may have already created a
1148 -- finalization master.
1149
1150 elsif Present (Finalization_Master (Ptr_Typ)) then
1151 return;
1152 end if;
1153
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;
1159
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.
1164
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"));
1169
1170 -- Internally generated access types use temporaries as their names
1171 -- due to possible collision with identical names coming from other
1172 -- packages.
1173
1174 else
1175 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1176 end if;
1177
1178 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1179
1180 -- Generate:
1181 -- <Ptr_Typ>FM : aliased Finalization_Master;
1182
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)));
1189
1190 -- Set the associated pool and primitive Finalize_Address of the new
1191 -- finalization master.
1192
1193 -- The access type has a user-defined storage pool, use it
1194
1195 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1196 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1197
1198 -- Otherwise the default choice is the global storage pool
1199
1200 else
1201 Pool_Id := RTE (RE_Global_Pool_Object);
1202 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1203 end if;
1204
1205 -- Generate:
1206 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1207
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))));
1217
1218 -- Finalize_Address is not generated in CodePeer mode because the
1219 -- body contains address arithmetic. Skip this step.
1220
1221 if CodePeer_Mode then
1222 null;
1223
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.
1228
1229 elsif Is_Frozen (Desig_Typ)
1230 and then Present (Finalize_Address (Desig_Typ))
1231
1232 -- The finalization master of an anonymous access type may need
1233 -- to be inserted in a specific place in the tree. For instance:
1234
1235 -- type Comp_Typ;
1236
1237 -- <finalization master of "access Comp_Typ">
1238
1239 -- type Rec_Typ is record
1240 -- Comp : access Comp_Typ;
1241 -- end record;
1242
1243 -- <freeze node for Comp_Typ>
1244 -- <freeze node for Rec_Typ>
1245
1246 -- Due to this oddity, the anonymous access type is stored for
1247 -- later processing (see below).
1248
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);
1254
1255 Append_To (Actions,
1256 Make_Set_Finalize_Address_Call
1257 (Loc => Loc,
1258 Ptr_Typ => Ptr_Typ));
1259
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).
1263
1264 else
1265 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1266 end if;
1267
1268 -- A finalization master created for an access designating a type
1269 -- with private components is inserted before a context-dependent
1270 -- node.
1271
1272 if For_Private then
1273
1274 -- At this point both the scope of the context and the insertion
1275 -- mode must be known.
1276
1277 pragma Assert (Present (Context_Scope));
1278 pragma Assert (Present (Insertion_Node));
1279
1280 Push_Scope (Context_Scope);
1281
1282 -- Treat use clauses as declarations and insert directly in front
1283 -- of them.
1284
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;
1292
1293 Pop_Scope;
1294
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.
1299
1300 elsif For_Lib_Level then
1301 pragma Assert (Present (Insertion_Node));
1302 Insert_Actions (Insertion_Node, Actions);
1303
1304 -- Otherwise the finalization master and its initialization become a
1305 -- part of the freeze node.
1306
1307 else
1308 Append_Freeze_Actions (Ptr_Typ, Actions);
1309 end if;
1310 end;
1311 end Build_Finalization_Master;
1312
1313 ---------------------
1314 -- Build_Finalizer --
1315 ---------------------
1316
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)
1324 is
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 :=
1331 not Restriction_Active (No_Exception_Propagation);
1332 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1333 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1334 For_Package : constant Boolean :=
1335 For_Package_Body or else For_Package_Spec;
1336 Loc : constant Source_Ptr := Sloc (N);
1337
1338 -- NOTE: Local variable declarations are conservative and do not create
1339 -- structures right from the start. Entities and lists are created once
1340 -- it has been established that N has at least one controlled object.
1341
1342 Components_Built : Boolean := False;
1343 -- A flag used to avoid double initialization of entities and lists. If
1344 -- the flag is set then the following variables have been initialized:
1345 -- Counter_Id
1346 -- Finalizer_Decls
1347 -- Finalizer_Stmts
1348 -- Jump_Alts
1349
1350 Counter_Id : Entity_Id := Empty;
1351 Counter_Val : Nat := 0;
1352 -- Name and value of the state counter
1353
1354 Decls : List_Id := No_List;
1355 -- Declarative region of N (if available). If N is a package declaration
1356 -- Decls denotes the visible declarations.
1357
1358 Finalizer_Data : Finalization_Exception_Data;
1359 -- Data for the exception
1360
1361 Finalizer_Decls : List_Id := No_List;
1362 -- Local variable declarations. This list holds the label declarations
1363 -- of all jump block alternatives as well as the declaration of the
1364 -- local exception occurrence and the raised flag:
1365 -- E : Exception_Occurrence;
1366 -- Raised : Boolean := False;
1367 -- L<counter value> : label;
1368
1369 Finalizer_Insert_Nod : Node_Id := Empty;
1370 -- Insertion point for the finalizer body. Depending on the context
1371 -- (Nkind of N) and the individual grouping of controlled objects, this
1372 -- node may denote a package declaration or body, package instantiation,
1373 -- block statement or a counter update statement.
1374
1375 Finalizer_Stmts : List_Id := No_List;
1376 -- The statement list of the finalizer body. It contains the following:
1377 --
1378 -- Abort_Defer; -- Added if abort is allowed
1379 -- <call to Prev_At_End> -- Added if exists
1380 -- <cleanup statements> -- Added if Acts_As_Clean
1381 -- <jump block> -- Added if Has_Ctrl_Objs
1382 -- <finalization statements> -- Added if Has_Ctrl_Objs
1383 -- <stack release> -- Added if Mark_Id exists
1384 -- Abort_Undefer; -- Added if abort is allowed
1385
1386 Has_Ctrl_Objs : Boolean := False;
1387 -- A general flag which denotes whether N has at least one controlled
1388 -- object.
1389
1390 Has_Tagged_Types : Boolean := False;
1391 -- A general flag which indicates whether N has at least one library-
1392 -- level tagged type declaration.
1393
1394 HSS : Node_Id := Empty;
1395 -- The sequence of statements of N (if available)
1396
1397 Jump_Alts : List_Id := No_List;
1398 -- Jump block alternatives. Depending on the value of the state counter,
1399 -- the control flow jumps to a sequence of finalization statements. This
1400 -- list contains the following:
1401 --
1402 -- when <counter value> =>
1403 -- goto L<counter value>;
1404
1405 Jump_Block_Insert_Nod : Node_Id := Empty;
1406 -- Specific point in the finalizer statements where the jump block is
1407 -- inserted.
1408
1409 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1410 -- The last controlled construct encountered when processing the top
1411 -- level lists of N. This can be a nested package, an instantiation or
1412 -- an object declaration.
1413
1414 Prev_At_End : Entity_Id := Empty;
1415 -- The previous at end procedure of the handled statements block of N
1416
1417 Priv_Decls : List_Id := No_List;
1418 -- The private declarations of N if N is a package declaration
1419
1420 Spec_Id : Entity_Id := Empty;
1421 Spec_Decls : List_Id := Top_Decls;
1422 Stmts : List_Id := No_List;
1423
1424 Tagged_Type_Stmts : List_Id := No_List;
1425 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1426 -- tagged types found in N.
1427
1428 -----------------------
1429 -- Local subprograms --
1430 -----------------------
1431
1432 procedure Build_Components;
1433 -- Create all entites and initialize all lists used in the creation of
1434 -- the finalizer.
1435
1436 procedure Create_Finalizer;
1437 -- Create the spec and body of the finalizer and insert them in the
1438 -- proper place in the tree depending on the context.
1439
1440 procedure Process_Declarations
1441 (Decls : List_Id;
1442 Preprocess : Boolean := False;
1443 Top_Level : Boolean := False);
1444 -- Inspect a list of declarations or statements which may contain
1445 -- objects that need finalization. When flag Preprocess is set, the
1446 -- routine will simply count the total number of controlled objects in
1447 -- Decls. Flag Top_Level denotes whether the processing is done for
1448 -- objects in nested package declarations or instances.
1449
1450 procedure Process_Object_Declaration
1451 (Decl : Node_Id;
1452 Has_No_Init : Boolean := False;
1453 Is_Protected : Boolean := False);
1454 -- Generate all the machinery associated with the finalization of a
1455 -- single object. Flag Has_No_Init is used to denote certain contexts
1456 -- where Decl does not have initialization call(s). Flag Is_Protected
1457 -- is set when Decl denotes a simple protected object.
1458
1459 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1460 -- Generate all the code necessary to unregister the external tag of a
1461 -- tagged type.
1462
1463 ----------------------
1464 -- Build_Components --
1465 ----------------------
1466
1467 procedure Build_Components is
1468 Counter_Decl : Node_Id;
1469 Counter_Typ : Entity_Id;
1470 Counter_Typ_Decl : Node_Id;
1471
1472 begin
1473 pragma Assert (Present (Decls));
1474
1475 -- This routine might be invoked several times when dealing with
1476 -- constructs that have two lists (either two declarative regions
1477 -- or declarations and statements). Avoid double initialization.
1478
1479 if Components_Built then
1480 return;
1481 end if;
1482
1483 Components_Built := True;
1484
1485 if Has_Ctrl_Objs then
1486
1487 -- Create entities for the counter, its type, the local exception
1488 -- and the raised flag.
1489
1490 Counter_Id := Make_Temporary (Loc, 'C');
1491 Counter_Typ := Make_Temporary (Loc, 'T');
1492
1493 Finalizer_Decls := New_List;
1494
1495 Build_Object_Declarations
1496 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1497
1498 -- Since the total number of controlled objects is always known,
1499 -- build a subtype of Natural with precise bounds. This allows
1500 -- the backend to optimize the case statement. Generate:
1501 --
1502 -- subtype Tnn is Natural range 0 .. Counter_Val;
1503
1504 Counter_Typ_Decl :=
1505 Make_Subtype_Declaration (Loc,
1506 Defining_Identifier => Counter_Typ,
1507 Subtype_Indication =>
1508 Make_Subtype_Indication (Loc,
1509 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1510 Constraint =>
1511 Make_Range_Constraint (Loc,
1512 Range_Expression =>
1513 Make_Range (Loc,
1514 Low_Bound =>
1515 Make_Integer_Literal (Loc, Uint_0),
1516 High_Bound =>
1517 Make_Integer_Literal (Loc, Counter_Val)))));
1518
1519 -- Generate the declaration of the counter itself:
1520 --
1521 -- Counter : Integer := 0;
1522
1523 Counter_Decl :=
1524 Make_Object_Declaration (Loc,
1525 Defining_Identifier => Counter_Id,
1526 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1527 Expression => Make_Integer_Literal (Loc, 0));
1528
1529 -- Set the type of the counter explicitly to prevent errors when
1530 -- examining object declarations later on.
1531
1532 Set_Etype (Counter_Id, Counter_Typ);
1533
1534 -- The counter and its type are inserted before the source
1535 -- declarations of N.
1536
1537 Prepend_To (Decls, Counter_Decl);
1538 Prepend_To (Decls, Counter_Typ_Decl);
1539
1540 -- The counter and its associated type must be manually analyzed
1541 -- since N has already been analyzed. Use the scope of the spec
1542 -- when inserting in a package.
1543
1544 if For_Package then
1545 Push_Scope (Spec_Id);
1546 Analyze (Counter_Typ_Decl);
1547 Analyze (Counter_Decl);
1548 Pop_Scope;
1549
1550 else
1551 Analyze (Counter_Typ_Decl);
1552 Analyze (Counter_Decl);
1553 end if;
1554
1555 Jump_Alts := New_List;
1556 end if;
1557
1558 -- If the context requires additional clean up, the finalization
1559 -- machinery is added after the clean up code.
1560
1561 if Acts_As_Clean then
1562 Finalizer_Stmts := Clean_Stmts;
1563 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1564 else
1565 Finalizer_Stmts := New_List;
1566 end if;
1567
1568 if Has_Tagged_Types then
1569 Tagged_Type_Stmts := New_List;
1570 end if;
1571 end Build_Components;
1572
1573 ----------------------
1574 -- Create_Finalizer --
1575 ----------------------
1576
1577 procedure Create_Finalizer is
1578 function New_Finalizer_Name return Name_Id;
1579 -- Create a fully qualified name of a package spec or body finalizer.
1580 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1581
1582 ------------------------
1583 -- New_Finalizer_Name --
1584 ------------------------
1585
1586 function New_Finalizer_Name return Name_Id is
1587 procedure New_Finalizer_Name (Id : Entity_Id);
1588 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1589 -- has a non-standard scope, process the scope first.
1590
1591 ------------------------
1592 -- New_Finalizer_Name --
1593 ------------------------
1594
1595 procedure New_Finalizer_Name (Id : Entity_Id) is
1596 begin
1597 if Scope (Id) = Standard_Standard then
1598 Get_Name_String (Chars (Id));
1599
1600 else
1601 New_Finalizer_Name (Scope (Id));
1602 Add_Str_To_Name_Buffer ("__");
1603 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1604 end if;
1605 end New_Finalizer_Name;
1606
1607 -- Start of processing for New_Finalizer_Name
1608
1609 begin
1610 -- Create the fully qualified name of the enclosing scope
1611
1612 New_Finalizer_Name (Spec_Id);
1613
1614 -- Generate:
1615 -- __finalize_[spec|body]
1616
1617 Add_Str_To_Name_Buffer ("__finalize_");
1618
1619 if For_Package_Spec then
1620 Add_Str_To_Name_Buffer ("spec");
1621 else
1622 Add_Str_To_Name_Buffer ("body");
1623 end if;
1624
1625 return Name_Find;
1626 end New_Finalizer_Name;
1627
1628 -- Local variables
1629
1630 Body_Id : Entity_Id;
1631 Fin_Body : Node_Id;
1632 Fin_Spec : Node_Id;
1633 Jump_Block : Node_Id;
1634 Label : Node_Id;
1635 Label_Id : Entity_Id;
1636
1637 -- Start of processing for Create_Finalizer
1638
1639 begin
1640 -- Step 1: Creation of the finalizer name
1641
1642 -- Packages must use a distinct name for their finalizers since the
1643 -- binder will have to generate calls to them by name. The name is
1644 -- of the following form:
1645
1646 -- xx__yy__finalize_[spec|body]
1647
1648 if For_Package then
1649 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1650 Set_Has_Qualified_Name (Fin_Id);
1651 Set_Has_Fully_Qualified_Name (Fin_Id);
1652
1653 -- The default name is _finalizer
1654
1655 else
1656 Fin_Id :=
1657 Make_Defining_Identifier (Loc,
1658 Chars => New_External_Name (Name_uFinalizer));
1659
1660 -- The visibility semantics of AT_END handlers force a strange
1661 -- separation of spec and body for stack-related finalizers:
1662
1663 -- declare : Enclosing_Scope
1664 -- procedure _finalizer;
1665 -- begin
1666 -- <controlled objects>
1667 -- procedure _finalizer is
1668 -- ...
1669 -- at end
1670 -- _finalizer;
1671 -- end;
1672
1673 -- Both spec and body are within the same construct and scope, but
1674 -- the body is part of the handled sequence of statements. This
1675 -- placement confuses the elaboration mechanism on targets where
1676 -- AT_END handlers are expanded into "when all others" handlers:
1677
1678 -- exception
1679 -- when all others =>
1680 -- _finalizer; -- appears to require elab checks
1681 -- at end
1682 -- _finalizer;
1683 -- end;
1684
1685 -- Since the compiler guarantees that the body of a _finalizer is
1686 -- always inserted in the same construct where the AT_END handler
1687 -- resides, there is no need for elaboration checks.
1688
1689 Set_Kill_Elaboration_Checks (Fin_Id);
1690
1691 -- Inlining the finalizer produces a substantial speedup at -O2.
1692 -- It is inlined by default at -O3. Either way, it is called
1693 -- exactly twice (once on the normal path, and once for
1694 -- exceptions/abort), so this won't bloat the code too much.
1695
1696 Set_Is_Inlined (Fin_Id);
1697 end if;
1698
1699 -- Step 2: Creation of the finalizer specification
1700
1701 -- Generate:
1702 -- procedure Fin_Id;
1703
1704 Fin_Spec :=
1705 Make_Subprogram_Declaration (Loc,
1706 Specification =>
1707 Make_Procedure_Specification (Loc,
1708 Defining_Unit_Name => Fin_Id));
1709
1710 -- Step 3: Creation of the finalizer body
1711
1712 if Has_Ctrl_Objs then
1713
1714 -- Add L0, the default destination to the jump block
1715
1716 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1717 Set_Entity (Label_Id,
1718 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1719 Label := Make_Label (Loc, Label_Id);
1720
1721 -- Generate:
1722 -- L0 : label;
1723
1724 Prepend_To (Finalizer_Decls,
1725 Make_Implicit_Label_Declaration (Loc,
1726 Defining_Identifier => Entity (Label_Id),
1727 Label_Construct => Label));
1728
1729 -- Generate:
1730 -- when others =>
1731 -- goto L0;
1732
1733 Append_To (Jump_Alts,
1734 Make_Case_Statement_Alternative (Loc,
1735 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1736 Statements => New_List (
1737 Make_Goto_Statement (Loc,
1738 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1739
1740 -- Generate:
1741 -- <<L0>>
1742
1743 Append_To (Finalizer_Stmts, Label);
1744
1745 -- Create the jump block which controls the finalization flow
1746 -- depending on the value of the state counter.
1747
1748 Jump_Block :=
1749 Make_Case_Statement (Loc,
1750 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1751 Alternatives => Jump_Alts);
1752
1753 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1754 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1755 else
1756 Prepend_To (Finalizer_Stmts, Jump_Block);
1757 end if;
1758 end if;
1759
1760 -- Add the library-level tagged type unregistration machinery before
1761 -- the jump block circuitry. This ensures that external tags will be
1762 -- removed even if a finalization exception occurs at some point.
1763
1764 if Has_Tagged_Types then
1765 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1766 end if;
1767
1768 -- Add a call to the previous At_End handler if it exists. The call
1769 -- must always precede the jump block.
1770
1771 if Present (Prev_At_End) then
1772 Prepend_To (Finalizer_Stmts,
1773 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1774
1775 -- Clear the At_End handler since we have already generated the
1776 -- proper replacement call for it.
1777
1778 Set_At_End_Proc (HSS, Empty);
1779 end if;
1780
1781 -- Release the secondary stack mark
1782
1783 if Present (Mark_Id) then
1784 Append_To (Finalizer_Stmts, Build_SS_Release_Call (Loc, Mark_Id));
1785 end if;
1786
1787 -- Protect the statements with abort defer/undefer. This is only when
1788 -- aborts are allowed and the clean up statements require deferral or
1789 -- there are controlled objects to be finalized. Note that the abort
1790 -- defer/undefer pair does not require an extra block because each
1791 -- finalization exception is caught in its corresponding finalization
1792 -- block. As a result, the call to Abort_Defer always takes place.
1793
1794 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1795 Prepend_To (Finalizer_Stmts,
1796 Build_Runtime_Call (Loc, RE_Abort_Defer));
1797
1798 Append_To (Finalizer_Stmts,
1799 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1800 end if;
1801
1802 -- The local exception does not need to be reraised for library-level
1803 -- finalizers. Note that this action must be carried out after object
1804 -- clean up, secondary stack release and abort undeferral. Generate:
1805
1806 -- if Raised and then not Abort then
1807 -- Raise_From_Controlled_Operation (E);
1808 -- end if;
1809
1810 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1811 Append_To (Finalizer_Stmts,
1812 Build_Raise_Statement (Finalizer_Data));
1813 end if;
1814
1815 -- Generate:
1816 -- procedure Fin_Id is
1817 -- Abort : constant Boolean := Triggered_By_Abort;
1818 -- <or>
1819 -- Abort : constant Boolean := False; -- no abort
1820
1821 -- E : Exception_Occurrence; -- All added if flag
1822 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1823 -- L0 : label;
1824 -- ...
1825 -- Lnn : label;
1826
1827 -- begin
1828 -- Abort_Defer; -- Added if abort is allowed
1829 -- <call to Prev_At_End> -- Added if exists
1830 -- <cleanup statements> -- Added if Acts_As_Clean
1831 -- <jump block> -- Added if Has_Ctrl_Objs
1832 -- <finalization statements> -- Added if Has_Ctrl_Objs
1833 -- <stack release> -- Added if Mark_Id exists
1834 -- Abort_Undefer; -- Added if abort is allowed
1835 -- <exception propagation> -- Added if Has_Ctrl_Objs
1836 -- end Fin_Id;
1837
1838 -- Create the body of the finalizer
1839
1840 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1841
1842 if For_Package then
1843 Set_Has_Qualified_Name (Body_Id);
1844 Set_Has_Fully_Qualified_Name (Body_Id);
1845 end if;
1846
1847 Fin_Body :=
1848 Make_Subprogram_Body (Loc,
1849 Specification =>
1850 Make_Procedure_Specification (Loc,
1851 Defining_Unit_Name => Body_Id),
1852 Declarations => Finalizer_Decls,
1853 Handled_Statement_Sequence =>
1854 Make_Handled_Sequence_Of_Statements (Loc,
1855 Statements => Finalizer_Stmts));
1856
1857 -- Step 4: Spec and body insertion, analysis
1858
1859 if For_Package then
1860
1861 -- If the package spec has private declarations, the finalizer
1862 -- body must be added to the end of the list in order to have
1863 -- visibility of all private controlled objects.
1864
1865 if For_Package_Spec then
1866 if Present (Priv_Decls) then
1867 Append_To (Priv_Decls, Fin_Spec);
1868 Append_To (Priv_Decls, Fin_Body);
1869 else
1870 Append_To (Decls, Fin_Spec);
1871 Append_To (Decls, Fin_Body);
1872 end if;
1873
1874 -- For package bodies, both the finalizer spec and body are
1875 -- inserted at the end of the package declarations.
1876
1877 else
1878 Append_To (Decls, Fin_Spec);
1879 Append_To (Decls, Fin_Body);
1880 end if;
1881
1882 -- Push the name of the package
1883
1884 Push_Scope (Spec_Id);
1885 Analyze (Fin_Spec);
1886 Analyze (Fin_Body);
1887 Pop_Scope;
1888
1889 -- Non-package case
1890
1891 else
1892 -- Create the spec for the finalizer. The At_End handler must be
1893 -- able to call the body which resides in a nested structure.
1894
1895 -- Generate:
1896 -- declare
1897 -- procedure Fin_Id; -- Spec
1898 -- begin
1899 -- <objects and possibly statements>
1900 -- procedure Fin_Id is ... -- Body
1901 -- <statements>
1902 -- at end
1903 -- Fin_Id; -- At_End handler
1904 -- end;
1905
1906 pragma Assert (Present (Spec_Decls));
1907
1908 Append_To (Spec_Decls, Fin_Spec);
1909 Analyze (Fin_Spec);
1910
1911 -- When the finalizer acts solely as a clean up routine, the body
1912 -- is inserted right after the spec.
1913
1914 if Acts_As_Clean and not Has_Ctrl_Objs then
1915 Insert_After (Fin_Spec, Fin_Body);
1916
1917 -- In all other cases the body is inserted after either:
1918 --
1919 -- 1) The counter update statement of the last controlled object
1920 -- 2) The last top level nested controlled package
1921 -- 3) The last top level controlled instantiation
1922
1923 else
1924 -- Manually freeze the spec. This is somewhat of a hack because
1925 -- a subprogram is frozen when its body is seen and the freeze
1926 -- node appears right before the body. However, in this case,
1927 -- the spec must be frozen earlier since the At_End handler
1928 -- must be able to call it.
1929 --
1930 -- declare
1931 -- procedure Fin_Id; -- Spec
1932 -- [Fin_Id] -- Freeze node
1933 -- begin
1934 -- ...
1935 -- at end
1936 -- Fin_Id; -- At_End handler
1937 -- end;
1938
1939 Ensure_Freeze_Node (Fin_Id);
1940 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
1941 Set_Is_Frozen (Fin_Id);
1942
1943 -- In the case where the last construct to contain a controlled
1944 -- object is either a nested package, an instantiation or a
1945 -- freeze node, the body must be inserted directly after the
1946 -- construct.
1947
1948 if Nkind_In (Last_Top_Level_Ctrl_Construct,
1949 N_Freeze_Entity,
1950 N_Package_Declaration,
1951 N_Package_Body)
1952 then
1953 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
1954 end if;
1955
1956 Insert_After (Finalizer_Insert_Nod, Fin_Body);
1957 end if;
1958
1959 Analyze (Fin_Body);
1960 end if;
1961 end Create_Finalizer;
1962
1963 --------------------------
1964 -- Process_Declarations --
1965 --------------------------
1966
1967 procedure Process_Declarations
1968 (Decls : List_Id;
1969 Preprocess : Boolean := False;
1970 Top_Level : Boolean := False)
1971 is
1972 Decl : Node_Id;
1973 Expr : Node_Id;
1974 Obj_Id : Entity_Id;
1975 Obj_Typ : Entity_Id;
1976 Pack_Id : Entity_Id;
1977 Spec : Node_Id;
1978 Typ : Entity_Id;
1979
1980 Old_Counter_Val : Nat;
1981 -- This variable is used to determine whether a nested package or
1982 -- instance contains at least one controlled object.
1983
1984 procedure Processing_Actions
1985 (Has_No_Init : Boolean := False;
1986 Is_Protected : Boolean := False);
1987 -- Depending on the mode of operation of Process_Declarations, either
1988 -- increment the controlled object counter, set the controlled object
1989 -- flag and store the last top level construct or process the current
1990 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1991 -- the current declaration may not have initialization proc(s). Flag
1992 -- Is_Protected should be set when the current declaration denotes a
1993 -- simple protected object.
1994
1995 ------------------------
1996 -- Processing_Actions --
1997 ------------------------
1998
1999 procedure Processing_Actions
2000 (Has_No_Init : Boolean := False;
2001 Is_Protected : Boolean := False)
2002 is
2003 begin
2004 -- Library-level tagged type
2005
2006 if Nkind (Decl) = N_Full_Type_Declaration then
2007 if Preprocess then
2008 Has_Tagged_Types := True;
2009
2010 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2011 Last_Top_Level_Ctrl_Construct := Decl;
2012 end if;
2013
2014 else
2015 Process_Tagged_Type_Declaration (Decl);
2016 end if;
2017
2018 -- Controlled object declaration
2019
2020 else
2021 if Preprocess then
2022 Counter_Val := Counter_Val + 1;
2023 Has_Ctrl_Objs := True;
2024
2025 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2026 Last_Top_Level_Ctrl_Construct := Decl;
2027 end if;
2028
2029 else
2030 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2031 end if;
2032 end if;
2033 end Processing_Actions;
2034
2035 -- Start of processing for Process_Declarations
2036
2037 begin
2038 if No (Decls) or else Is_Empty_List (Decls) then
2039 return;
2040 end if;
2041
2042 -- Process all declarations in reverse order
2043
2044 Decl := Last_Non_Pragma (Decls);
2045 while Present (Decl) loop
2046
2047 -- Library-level tagged types
2048
2049 if Nkind (Decl) = N_Full_Type_Declaration then
2050 Typ := Defining_Identifier (Decl);
2051
2052 -- Ignored Ghost types do not need any cleanup actions because
2053 -- they will not appear in the final tree.
2054
2055 if Is_Ignored_Ghost_Entity (Typ) then
2056 null;
2057
2058 elsif Is_Tagged_Type (Typ)
2059 and then Is_Library_Level_Entity (Typ)
2060 and then Convention (Typ) = Convention_Ada
2061 and then Present (Access_Disp_Table (Typ))
2062 and then RTE_Available (RE_Register_Tag)
2063 and then not Is_Abstract_Type (Typ)
2064 and then not No_Run_Time_Mode
2065 then
2066 Processing_Actions;
2067 end if;
2068
2069 -- Regular object declarations
2070
2071 elsif Nkind (Decl) = N_Object_Declaration then
2072 Obj_Id := Defining_Identifier (Decl);
2073 Obj_Typ := Base_Type (Etype (Obj_Id));
2074 Expr := Expression (Decl);
2075
2076 -- Bypass any form of processing for objects which have their
2077 -- finalization disabled. This applies only to objects at the
2078 -- library level.
2079
2080 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2081 null;
2082
2083 -- Transient variables are treated separately in order to
2084 -- minimize the size of the generated code. For details, see
2085 -- Process_Transient_Objects.
2086
2087 elsif Is_Processed_Transient (Obj_Id) then
2088 null;
2089
2090 -- Ignored Ghost objects do not need any cleanup actions
2091 -- because they will not appear in the final tree.
2092
2093 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2094 null;
2095
2096 -- The expansion of iterator loops generates an object
2097 -- declaration where the Ekind is explicitly set to loop
2098 -- parameter. This is to ensure that the loop parameter behaves
2099 -- as a constant from user code point of view. Such object are
2100 -- never controlled and do not require finalization.
2101
2102 elsif Ekind (Obj_Id) = E_Loop_Parameter then
2103 null;
2104
2105 -- The object is of the form:
2106 -- Obj : [constant] Typ [:= Expr];
2107
2108 -- Do not process tag-to-class-wide conversions because they do
2109 -- not yield an object. Do not process the incomplete view of a
2110 -- deferred constant. Note that an object initialized by means
2111 -- of a build-in-place function call may appear as a deferred
2112 -- constant after expansion activities. These kinds of objects
2113 -- must be finalized.
2114
2115 elsif not Is_Imported (Obj_Id)
2116 and then Needs_Finalization (Obj_Typ)
2117 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
2118 and then not (Ekind (Obj_Id) = E_Constant
2119 and then not Has_Completion (Obj_Id)
2120 and then No (BIP_Initialization_Call (Obj_Id)))
2121 then
2122 Processing_Actions;
2123
2124 -- The object is of the form:
2125 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2126
2127 -- Obj : Access_Typ :=
2128 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2129
2130 elsif Is_Access_Type (Obj_Typ)
2131 and then Needs_Finalization
2132 (Available_View (Designated_Type (Obj_Typ)))
2133 and then Present (Expr)
2134 and then
2135 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2136 or else
2137 (Is_Non_BIP_Func_Call (Expr)
2138 and then not Is_Related_To_Func_Return (Obj_Id)))
2139 then
2140 Processing_Actions (Has_No_Init => True);
2141
2142 -- Processing for "hook" objects generated for controlled
2143 -- transients declared inside an Expression_With_Actions.
2144
2145 elsif Is_Access_Type (Obj_Typ)
2146 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2147 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2148 N_Object_Declaration
2149 then
2150 Processing_Actions (Has_No_Init => True);
2151
2152 -- Process intermediate results of an if expression with one
2153 -- of the alternatives using a controlled function call.
2154
2155 elsif Is_Access_Type (Obj_Typ)
2156 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2157 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2158 N_Defining_Identifier
2159 and then Present (Expr)
2160 and then Nkind (Expr) = N_Null
2161 then
2162 Processing_Actions (Has_No_Init => True);
2163
2164 -- Simple protected objects which use type System.Tasking.
2165 -- Protected_Objects.Protection to manage their locks should
2166 -- be treated as controlled since they require manual cleanup.
2167 -- The only exception is illustrated in the following example:
2168
2169 -- package Pkg is
2170 -- type Ctrl is new Controlled ...
2171 -- procedure Finalize (Obj : in out Ctrl);
2172 -- Lib_Obj : Ctrl;
2173 -- end Pkg;
2174
2175 -- package body Pkg is
2176 -- protected Prot is
2177 -- procedure Do_Something (Obj : in out Ctrl);
2178 -- end Prot;
2179
2180 -- protected body Prot is
2181 -- procedure Do_Something (Obj : in out Ctrl) is ...
2182 -- end Prot;
2183
2184 -- procedure Finalize (Obj : in out Ctrl) is
2185 -- begin
2186 -- Prot.Do_Something (Obj);
2187 -- end Finalize;
2188 -- end Pkg;
2189
2190 -- Since for the most part entities in package bodies depend on
2191 -- those in package specs, Prot's lock should be cleaned up
2192 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2193 -- This act however attempts to invoke Do_Something and fails
2194 -- because the lock has disappeared.
2195
2196 elsif Ekind (Obj_Id) = E_Variable
2197 and then not In_Library_Level_Package_Body (Obj_Id)
2198 and then (Is_Simple_Protected_Type (Obj_Typ)
2199 or else Has_Simple_Protected_Object (Obj_Typ))
2200 then
2201 Processing_Actions (Is_Protected => True);
2202 end if;
2203
2204 -- Specific cases of object renamings
2205
2206 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2207 Obj_Id := Defining_Identifier (Decl);
2208 Obj_Typ := Base_Type (Etype (Obj_Id));
2209
2210 -- Bypass any form of processing for objects which have their
2211 -- finalization disabled. This applies only to objects at the
2212 -- library level.
2213
2214 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2215 null;
2216
2217 -- Ignored Ghost object renamings do not need any cleanup
2218 -- actions because they will not appear in the final tree.
2219
2220 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2221 null;
2222
2223 -- Return object of a build-in-place function. This case is
2224 -- recognized and marked by the expansion of an extended return
2225 -- statement (see Expand_N_Extended_Return_Statement).
2226
2227 elsif Needs_Finalization (Obj_Typ)
2228 and then Is_Return_Object (Obj_Id)
2229 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2230 then
2231 Processing_Actions (Has_No_Init => True);
2232
2233 -- Detect a case where a source object has been initialized by
2234 -- a controlled function call or another object which was later
2235 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2236
2237 -- Obj1 : CW_Type := Src_Obj;
2238 -- Obj2 : CW_Type := Function_Call (...);
2239
2240 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2241 -- Tmp : ... := Function_Call (...)'reference;
2242 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2243
2244 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
2245 Processing_Actions (Has_No_Init => True);
2246 end if;
2247
2248 -- Inspect the freeze node of an access-to-controlled type and
2249 -- look for a delayed finalization master. This case arises when
2250 -- the freeze actions are inserted at a later time than the
2251 -- expansion of the context. Since Build_Finalizer is never called
2252 -- on a single construct twice, the master will be ultimately
2253 -- left out and never finalized. This is also needed for freeze
2254 -- actions of designated types themselves, since in some cases the
2255 -- finalization master is associated with a designated type's
2256 -- freeze node rather than that of the access type (see handling
2257 -- for freeze actions in Build_Finalization_Master).
2258
2259 elsif Nkind (Decl) = N_Freeze_Entity
2260 and then Present (Actions (Decl))
2261 then
2262 Typ := Entity (Decl);
2263
2264 -- Freeze nodes for ignored Ghost types do not need cleanup
2265 -- actions because they will never appear in the final tree.
2266
2267 if Is_Ignored_Ghost_Entity (Typ) then
2268 null;
2269
2270 elsif (Is_Access_Type (Typ)
2271 and then not Is_Access_Subprogram_Type (Typ)
2272 and then Needs_Finalization
2273 (Available_View (Designated_Type (Typ))))
2274 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2275 then
2276 Old_Counter_Val := Counter_Val;
2277
2278 -- Freeze nodes are considered to be identical to packages
2279 -- and blocks in terms of nesting. The difference is that
2280 -- a finalization master created inside the freeze node is
2281 -- at the same nesting level as the node itself.
2282
2283 Process_Declarations (Actions (Decl), Preprocess);
2284
2285 -- The freeze node contains a finalization master
2286
2287 if Preprocess
2288 and then Top_Level
2289 and then No (Last_Top_Level_Ctrl_Construct)
2290 and then Counter_Val > Old_Counter_Val
2291 then
2292 Last_Top_Level_Ctrl_Construct := Decl;
2293 end if;
2294 end if;
2295
2296 -- Nested package declarations, avoid generics
2297
2298 elsif Nkind (Decl) = N_Package_Declaration then
2299 Pack_Id := Defining_Entity (Decl);
2300 Spec := Specification (Decl);
2301
2302 -- Do not inspect an ignored Ghost package because all code
2303 -- found within will not appear in the final tree.
2304
2305 if Is_Ignored_Ghost_Entity (Pack_Id) then
2306 null;
2307
2308 elsif Ekind (Pack_Id) /= E_Generic_Package then
2309 Old_Counter_Val := Counter_Val;
2310 Process_Declarations
2311 (Private_Declarations (Spec), Preprocess);
2312 Process_Declarations
2313 (Visible_Declarations (Spec), Preprocess);
2314
2315 -- Either the visible or the private declarations contain a
2316 -- controlled object. The nested package declaration is the
2317 -- last such construct.
2318
2319 if Preprocess
2320 and then Top_Level
2321 and then No (Last_Top_Level_Ctrl_Construct)
2322 and then Counter_Val > Old_Counter_Val
2323 then
2324 Last_Top_Level_Ctrl_Construct := Decl;
2325 end if;
2326 end if;
2327
2328 -- Nested package bodies, avoid generics
2329
2330 elsif Nkind (Decl) = N_Package_Body then
2331
2332 -- Do not inspect an ignored Ghost package body because all
2333 -- code found within will not appear in the final tree.
2334
2335 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2336 null;
2337
2338 elsif Ekind (Corresponding_Spec (Decl)) /=
2339 E_Generic_Package
2340 then
2341 Old_Counter_Val := Counter_Val;
2342 Process_Declarations (Declarations (Decl), Preprocess);
2343
2344 -- The nested package body is the last construct to contain
2345 -- a controlled object.
2346
2347 if Preprocess
2348 and then Top_Level
2349 and then No (Last_Top_Level_Ctrl_Construct)
2350 and then Counter_Val > Old_Counter_Val
2351 then
2352 Last_Top_Level_Ctrl_Construct := Decl;
2353 end if;
2354 end if;
2355
2356 -- Handle a rare case caused by a controlled transient variable
2357 -- created as part of a record init proc. The variable is wrapped
2358 -- in a block, but the block is not associated with a transient
2359 -- scope.
2360
2361 elsif Nkind (Decl) = N_Block_Statement
2362 and then Inside_Init_Proc
2363 then
2364 Old_Counter_Val := Counter_Val;
2365
2366 if Present (Handled_Statement_Sequence (Decl)) then
2367 Process_Declarations
2368 (Statements (Handled_Statement_Sequence (Decl)),
2369 Preprocess);
2370 end if;
2371
2372 Process_Declarations (Declarations (Decl), Preprocess);
2373
2374 -- Either the declaration or statement list of the block has a
2375 -- controlled object.
2376
2377 if Preprocess
2378 and then Top_Level
2379 and then No (Last_Top_Level_Ctrl_Construct)
2380 and then Counter_Val > Old_Counter_Val
2381 then
2382 Last_Top_Level_Ctrl_Construct := Decl;
2383 end if;
2384
2385 -- Handle the case where the original context has been wrapped in
2386 -- a block to avoid interference between exception handlers and
2387 -- At_End handlers. Treat the block as transparent and process its
2388 -- contents.
2389
2390 elsif Nkind (Decl) = N_Block_Statement
2391 and then Is_Finalization_Wrapper (Decl)
2392 then
2393 if Present (Handled_Statement_Sequence (Decl)) then
2394 Process_Declarations
2395 (Statements (Handled_Statement_Sequence (Decl)),
2396 Preprocess);
2397 end if;
2398
2399 Process_Declarations (Declarations (Decl), Preprocess);
2400 end if;
2401
2402 Prev_Non_Pragma (Decl);
2403 end loop;
2404 end Process_Declarations;
2405
2406 --------------------------------
2407 -- Process_Object_Declaration --
2408 --------------------------------
2409
2410 procedure Process_Object_Declaration
2411 (Decl : Node_Id;
2412 Has_No_Init : Boolean := False;
2413 Is_Protected : Boolean := False)
2414 is
2415 Loc : constant Source_Ptr := Sloc (Decl);
2416 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2417
2418 Init_Typ : Entity_Id;
2419 -- The initialization type of the related object declaration. Note
2420 -- that this is not necessarily the same type as Obj_Typ because of
2421 -- possible type derivations.
2422
2423 Obj_Typ : Entity_Id;
2424 -- The type of the related object declaration
2425
2426 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2427 -- Func_Id denotes a build-in-place function. Generate the following
2428 -- cleanup code:
2429 --
2430 -- if BIPallocfrom > Secondary_Stack'Pos
2431 -- and then BIPfinalizationmaster /= null
2432 -- then
2433 -- declare
2434 -- type Ptr_Typ is access Obj_Typ;
2435 -- for Ptr_Typ'Storage_Pool
2436 -- use Base_Pool (BIPfinalizationmaster);
2437 -- begin
2438 -- Free (Ptr_Typ (Temp));
2439 -- end;
2440 -- end if;
2441 --
2442 -- Obj_Typ is the type of the current object, Temp is the original
2443 -- allocation which Obj_Id renames.
2444
2445 procedure Find_Last_Init
2446 (Last_Init : out Node_Id;
2447 Body_Insert : out Node_Id);
2448 -- Find the last initialization call related to object declaration
2449 -- Decl. Last_Init denotes the last initialization call which follows
2450 -- Decl. Body_Insert denotes a node where the finalizer body could be
2451 -- potentially inserted after (if blocks are involved).
2452
2453 -----------------------------
2454 -- Build_BIP_Cleanup_Stmts --
2455 -----------------------------
2456
2457 function Build_BIP_Cleanup_Stmts
2458 (Func_Id : Entity_Id) return Node_Id
2459 is
2460 Decls : constant List_Id := New_List;
2461 Fin_Mas_Id : constant Entity_Id :=
2462 Build_In_Place_Formal
2463 (Func_Id, BIP_Finalization_Master);
2464 Func_Typ : constant Entity_Id := Etype (Func_Id);
2465 Temp_Id : constant Entity_Id :=
2466 Entity (Prefix (Name (Parent (Obj_Id))));
2467
2468 Cond : Node_Id;
2469 Free_Blk : Node_Id;
2470 Free_Stmt : Node_Id;
2471 Pool_Id : Entity_Id;
2472 Ptr_Typ : Entity_Id;
2473
2474 begin
2475 -- Generate:
2476 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2477
2478 Pool_Id := Make_Temporary (Loc, 'P');
2479
2480 Append_To (Decls,
2481 Make_Object_Renaming_Declaration (Loc,
2482 Defining_Identifier => Pool_Id,
2483 Subtype_Mark =>
2484 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2485 Name =>
2486 Make_Explicit_Dereference (Loc,
2487 Prefix =>
2488 Make_Function_Call (Loc,
2489 Name =>
2490 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2491 Parameter_Associations => New_List (
2492 Make_Explicit_Dereference (Loc,
2493 Prefix =>
2494 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2495
2496 -- Create an access type which uses the storage pool of the
2497 -- caller's finalization master.
2498
2499 -- Generate:
2500 -- type Ptr_Typ is access Func_Typ;
2501
2502 Ptr_Typ := Make_Temporary (Loc, 'P');
2503
2504 Append_To (Decls,
2505 Make_Full_Type_Declaration (Loc,
2506 Defining_Identifier => Ptr_Typ,
2507 Type_Definition =>
2508 Make_Access_To_Object_Definition (Loc,
2509 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2510
2511 -- Perform minor decoration in order to set the master and the
2512 -- storage pool attributes.
2513
2514 Set_Ekind (Ptr_Typ, E_Access_Type);
2515 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2516 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2517
2518 -- Create an explicit free statement. Note that the free uses the
2519 -- caller's pool expressed as a renaming.
2520
2521 Free_Stmt :=
2522 Make_Free_Statement (Loc,
2523 Expression =>
2524 Unchecked_Convert_To (Ptr_Typ,
2525 New_Occurrence_Of (Temp_Id, Loc)));
2526
2527 Set_Storage_Pool (Free_Stmt, Pool_Id);
2528
2529 -- Create a block to house the dummy type and the instantiation as
2530 -- well as to perform the cleanup the temporary.
2531
2532 -- Generate:
2533 -- declare
2534 -- <Decls>
2535 -- begin
2536 -- Free (Ptr_Typ (Temp_Id));
2537 -- end;
2538
2539 Free_Blk :=
2540 Make_Block_Statement (Loc,
2541 Declarations => Decls,
2542 Handled_Statement_Sequence =>
2543 Make_Handled_Sequence_Of_Statements (Loc,
2544 Statements => New_List (Free_Stmt)));
2545
2546 -- Generate:
2547 -- if BIPfinalizationmaster /= null then
2548
2549 Cond :=
2550 Make_Op_Ne (Loc,
2551 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2552 Right_Opnd => Make_Null (Loc));
2553
2554 -- For constrained or tagged results escalate the condition to
2555 -- include the allocation format. Generate:
2556
2557 -- if BIPallocform > Secondary_Stack'Pos
2558 -- and then BIPfinalizationmaster /= null
2559 -- then
2560
2561 if not Is_Constrained (Func_Typ)
2562 or else Is_Tagged_Type (Func_Typ)
2563 then
2564 declare
2565 Alloc : constant Entity_Id :=
2566 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2567 begin
2568 Cond :=
2569 Make_And_Then (Loc,
2570 Left_Opnd =>
2571 Make_Op_Gt (Loc,
2572 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2573 Right_Opnd =>
2574 Make_Integer_Literal (Loc,
2575 UI_From_Int
2576 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2577
2578 Right_Opnd => Cond);
2579 end;
2580 end if;
2581
2582 -- Generate:
2583 -- if <Cond> then
2584 -- <Free_Blk>
2585 -- end if;
2586
2587 return
2588 Make_If_Statement (Loc,
2589 Condition => Cond,
2590 Then_Statements => New_List (Free_Blk));
2591 end Build_BIP_Cleanup_Stmts;
2592
2593 --------------------
2594 -- Find_Last_Init --
2595 --------------------
2596
2597 procedure Find_Last_Init
2598 (Last_Init : out Node_Id;
2599 Body_Insert : out Node_Id)
2600 is
2601 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2602 -- Find the last initialization call within the statements of
2603 -- block Blk.
2604
2605 function Is_Init_Call (N : Node_Id) return Boolean;
2606 -- Determine whether node N denotes one of the initialization
2607 -- procedures of types Init_Typ or Obj_Typ.
2608
2609 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2610 -- Given a statement which is part of a list, return the next
2611 -- statement while skipping over dynamic elab checks.
2612
2613 -----------------------------
2614 -- Find_Last_Init_In_Block --
2615 -----------------------------
2616
2617 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2618 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2619 Stmt : Node_Id;
2620
2621 begin
2622 -- Examine the individual statements of the block in reverse to
2623 -- locate the last initialization call.
2624
2625 if Present (HSS) and then Present (Statements (HSS)) then
2626 Stmt := Last (Statements (HSS));
2627 while Present (Stmt) loop
2628
2629 -- Peek inside nested blocks in case aborts are allowed
2630
2631 if Nkind (Stmt) = N_Block_Statement then
2632 return Find_Last_Init_In_Block (Stmt);
2633
2634 elsif Is_Init_Call (Stmt) then
2635 return Stmt;
2636 end if;
2637
2638 Prev (Stmt);
2639 end loop;
2640 end if;
2641
2642 return Empty;
2643 end Find_Last_Init_In_Block;
2644
2645 ------------------
2646 -- Is_Init_Call --
2647 ------------------
2648
2649 function Is_Init_Call (N : Node_Id) return Boolean is
2650 function Is_Init_Proc_Of
2651 (Subp_Id : Entity_Id;
2652 Typ : Entity_Id) return Boolean;
2653 -- Determine whether subprogram Subp_Id is a valid init proc of
2654 -- type Typ.
2655
2656 ---------------------
2657 -- Is_Init_Proc_Of --
2658 ---------------------
2659
2660 function Is_Init_Proc_Of
2661 (Subp_Id : Entity_Id;
2662 Typ : Entity_Id) return Boolean
2663 is
2664 Deep_Init : Entity_Id := Empty;
2665 Prim_Init : Entity_Id := Empty;
2666 Type_Init : Entity_Id := Empty;
2667
2668 begin
2669 -- Obtain all possible initialization routines of the
2670 -- related type and try to match the subprogram entity
2671 -- against one of them.
2672
2673 -- Deep_Initialize
2674
2675 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2676
2677 -- Primitive Initialize
2678
2679 if Is_Controlled (Typ) then
2680 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2681
2682 if Present (Prim_Init) then
2683 Prim_Init := Ultimate_Alias (Prim_Init);
2684 end if;
2685 end if;
2686
2687 -- Type initialization routine
2688
2689 if Has_Non_Null_Base_Init_Proc (Typ) then
2690 Type_Init := Base_Init_Proc (Typ);
2691 end if;
2692
2693 return
2694 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2695 or else
2696 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2697 or else
2698 (Present (Type_Init) and then Subp_Id = Type_Init);
2699 end Is_Init_Proc_Of;
2700
2701 -- Local variables
2702
2703 Call_Id : Entity_Id;
2704
2705 -- Start of processing for Is_Init_Call
2706
2707 begin
2708 if Nkind (N) = N_Procedure_Call_Statement
2709 and then Nkind (Name (N)) = N_Identifier
2710 then
2711 Call_Id := Entity (Name (N));
2712
2713 -- Consider both the type of the object declaration and its
2714 -- related initialization type.
2715
2716 return
2717 Is_Init_Proc_Of (Call_Id, Init_Typ)
2718 or else
2719 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2720 end if;
2721
2722 return False;
2723 end Is_Init_Call;
2724
2725 -----------------------------
2726 -- Next_Suitable_Statement --
2727 -----------------------------
2728
2729 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2730 Result : Node_Id := Next (Stmt);
2731
2732 begin
2733 -- Skip over access-before-elaboration checks
2734
2735 if Dynamic_Elaboration_Checks
2736 and then Nkind (Result) = N_Raise_Program_Error
2737 then
2738 Result := Next (Result);
2739 end if;
2740
2741 return Result;
2742 end Next_Suitable_Statement;
2743
2744 -- Local variables
2745
2746 Call : Node_Id;
2747 Stmt : Node_Id;
2748 Stmt_2 : Node_Id;
2749
2750 Deep_Init_Found : Boolean := False;
2751 -- A flag set when a call to [Deep_]Initialize has been found
2752
2753 -- Start of processing for Find_Last_Init
2754
2755 begin
2756 Last_Init := Decl;
2757 Body_Insert := Empty;
2758
2759 -- Object renamings and objects associated with controlled
2760 -- function results do not require initialization.
2761
2762 if Has_No_Init then
2763 return;
2764 end if;
2765
2766 Stmt := Next_Suitable_Statement (Decl);
2767
2768 -- Nothing to do for an object with suppressed initialization
2769
2770 if No_Initialization (Decl) then
2771 return;
2772
2773 -- In all other cases the initialization calls follow the related
2774 -- object. The general structure of object initialization built by
2775 -- routine Default_Initialize_Object is as follows:
2776
2777 -- [begin -- aborts allowed
2778 -- Abort_Defer;]
2779 -- Type_Init_Proc (Obj);
2780 -- [begin] -- exceptions allowed
2781 -- Deep_Initialize (Obj);
2782 -- [exception -- exceptions allowed
2783 -- when others =>
2784 -- Deep_Finalize (Obj, Self => False);
2785 -- raise;
2786 -- end;]
2787 -- [at end -- aborts allowed
2788 -- Abort_Undefer;
2789 -- end;]
2790
2791 -- When aborts are allowed, the initialization calls are housed
2792 -- within a block.
2793
2794 elsif Nkind (Stmt) = N_Block_Statement then
2795 Last_Init := Find_Last_Init_In_Block (Stmt);
2796 Body_Insert := Stmt;
2797
2798 -- Otherwise the initialization calls follow the related object
2799
2800 else
2801 Stmt_2 := Next_Suitable_Statement (Stmt);
2802
2803 -- Check for an optional call to Deep_Initialize which may
2804 -- appear within a block depending on whether the object has
2805 -- controlled components.
2806
2807 if Present (Stmt_2) then
2808 if Nkind (Stmt_2) = N_Block_Statement then
2809 Call := Find_Last_Init_In_Block (Stmt_2);
2810
2811 if Present (Call) then
2812 Deep_Init_Found := True;
2813 Last_Init := Call;
2814 Body_Insert := Stmt_2;
2815 end if;
2816
2817 elsif Is_Init_Call (Stmt_2) then
2818 Deep_Init_Found := True;
2819 Last_Init := Stmt_2;
2820 Body_Insert := Last_Init;
2821 end if;
2822 end if;
2823
2824 -- If the object lacks a call to Deep_Initialize, then it must
2825 -- have a call to its related type init proc.
2826
2827 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
2828 Last_Init := Stmt;
2829 Body_Insert := Last_Init;
2830 end if;
2831 end if;
2832 end Find_Last_Init;
2833
2834 -- Local variables
2835
2836 Body_Ins : Node_Id;
2837 Count_Ins : Node_Id;
2838 Fin_Call : Node_Id;
2839 Fin_Stmts : List_Id;
2840 Inc_Decl : Node_Id;
2841 Label : Node_Id;
2842 Label_Id : Entity_Id;
2843 Obj_Ref : Node_Id;
2844
2845 -- Start of processing for Process_Object_Declaration
2846
2847 begin
2848 -- Handle the object type and the reference to the object
2849
2850 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2851 Obj_Typ := Base_Type (Etype (Obj_Id));
2852
2853 loop
2854 if Is_Access_Type (Obj_Typ) then
2855 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2856 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2857
2858 elsif Is_Concurrent_Type (Obj_Typ)
2859 and then Present (Corresponding_Record_Type (Obj_Typ))
2860 then
2861 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
2862 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2863
2864 elsif Is_Private_Type (Obj_Typ)
2865 and then Present (Full_View (Obj_Typ))
2866 then
2867 Obj_Typ := Full_View (Obj_Typ);
2868 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2869
2870 elsif Obj_Typ /= Base_Type (Obj_Typ) then
2871 Obj_Typ := Base_Type (Obj_Typ);
2872 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2873
2874 else
2875 exit;
2876 end if;
2877 end loop;
2878
2879 Set_Etype (Obj_Ref, Obj_Typ);
2880
2881 -- Handle the initialization type of the object declaration
2882
2883 Init_Typ := Obj_Typ;
2884 loop
2885 if Is_Private_Type (Init_Typ)
2886 and then Present (Full_View (Init_Typ))
2887 then
2888 Init_Typ := Full_View (Init_Typ);
2889
2890 elsif Is_Untagged_Derivation (Init_Typ) then
2891 Init_Typ := Root_Type (Init_Typ);
2892
2893 else
2894 exit;
2895 end if;
2896 end loop;
2897
2898 -- Set a new value for the state counter and insert the statement
2899 -- after the object declaration. Generate:
2900
2901 -- Counter := <value>;
2902
2903 Inc_Decl :=
2904 Make_Assignment_Statement (Loc,
2905 Name => New_Occurrence_Of (Counter_Id, Loc),
2906 Expression => Make_Integer_Literal (Loc, Counter_Val));
2907
2908 -- Insert the counter after all initialization has been done. The
2909 -- place of insertion depends on the context.
2910
2911 if Ekind_In (Obj_Id, E_Constant, E_Variable) then
2912
2913 -- The object is initialized by a build-in-place function call.
2914 -- The counter insertion point is after the function call.
2915
2916 if Present (BIP_Initialization_Call (Obj_Id)) then
2917 Count_Ins := BIP_Initialization_Call (Obj_Id);
2918 Body_Ins := Empty;
2919
2920 -- The object is initialized by an aggregate. Insert the counter
2921 -- after the last aggregate assignment.
2922
2923 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
2924 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
2925 Body_Ins := Empty;
2926
2927 -- In all other cases the counter is inserted after the last call
2928 -- to either [Deep_]Initialize or the type-specific init proc.
2929
2930 else
2931 Find_Last_Init (Count_Ins, Body_Ins);
2932 end if;
2933
2934 -- In all other cases the counter is inserted after the last call to
2935 -- either [Deep_]Initialize or the type-specific init proc.
2936
2937 else
2938 Find_Last_Init (Count_Ins, Body_Ins);
2939 end if;
2940
2941 Insert_After (Count_Ins, Inc_Decl);
2942 Analyze (Inc_Decl);
2943
2944 -- If the current declaration is the last in the list, the finalizer
2945 -- body needs to be inserted after the set counter statement for the
2946 -- current object declaration. This is complicated by the fact that
2947 -- the set counter statement may appear in abort deferred block. In
2948 -- that case, the proper insertion place is after the block.
2949
2950 if No (Finalizer_Insert_Nod) then
2951
2952 -- Insertion after an abort deffered block
2953
2954 if Present (Body_Ins) then
2955 Finalizer_Insert_Nod := Body_Ins;
2956 else
2957 Finalizer_Insert_Nod := Inc_Decl;
2958 end if;
2959 end if;
2960
2961 -- Create the associated label with this object, generate:
2962
2963 -- L<counter> : label;
2964
2965 Label_Id :=
2966 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
2967 Set_Entity
2968 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
2969 Label := Make_Label (Loc, Label_Id);
2970
2971 Prepend_To (Finalizer_Decls,
2972 Make_Implicit_Label_Declaration (Loc,
2973 Defining_Identifier => Entity (Label_Id),
2974 Label_Construct => Label));
2975
2976 -- Create the associated jump with this object, generate:
2977
2978 -- when <counter> =>
2979 -- goto L<counter>;
2980
2981 Prepend_To (Jump_Alts,
2982 Make_Case_Statement_Alternative (Loc,
2983 Discrete_Choices => New_List (
2984 Make_Integer_Literal (Loc, Counter_Val)),
2985 Statements => New_List (
2986 Make_Goto_Statement (Loc,
2987 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
2988
2989 -- Insert the jump destination, generate:
2990
2991 -- <<L<counter>>>
2992
2993 Append_To (Finalizer_Stmts, Label);
2994
2995 -- Processing for simple protected objects. Such objects require
2996 -- manual finalization of their lock managers.
2997
2998 if Is_Protected then
2999 Fin_Stmts := No_List;
3000
3001 if Is_Simple_Protected_Type (Obj_Typ) then
3002 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3003
3004 if Present (Fin_Call) then
3005 Fin_Stmts := New_List (Fin_Call);
3006 end if;
3007
3008 elsif Has_Simple_Protected_Object (Obj_Typ) then
3009 if Is_Record_Type (Obj_Typ) then
3010 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3011 elsif Is_Array_Type (Obj_Typ) then
3012 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3013 end if;
3014 end if;
3015
3016 -- Generate:
3017 -- begin
3018 -- System.Tasking.Protected_Objects.Finalize_Protection
3019 -- (Obj._object);
3020
3021 -- exception
3022 -- when others =>
3023 -- null;
3024 -- end;
3025
3026 if Present (Fin_Stmts) then
3027 Append_To (Finalizer_Stmts,
3028 Make_Block_Statement (Loc,
3029 Handled_Statement_Sequence =>
3030 Make_Handled_Sequence_Of_Statements (Loc,
3031 Statements => Fin_Stmts,
3032
3033 Exception_Handlers => New_List (
3034 Make_Exception_Handler (Loc,
3035 Exception_Choices => New_List (
3036 Make_Others_Choice (Loc)),
3037
3038 Statements => New_List (
3039 Make_Null_Statement (Loc)))))));
3040 end if;
3041
3042 -- Processing for regular controlled objects
3043
3044 else
3045 -- Generate:
3046 -- begin
3047 -- [Deep_]Finalize (Obj);
3048
3049 -- exception
3050 -- when Id : others =>
3051 -- if not Raised then
3052 -- Raised := True;
3053 -- Save_Occurrence (E, Id);
3054 -- end if;
3055 -- end;
3056
3057 Fin_Call :=
3058 Make_Final_Call (
3059 Obj_Ref => Obj_Ref,
3060 Typ => Obj_Typ);
3061
3062 -- For CodePeer, the exception handlers normally generated here
3063 -- generate complex flowgraphs which result in capacity problems.
3064 -- Omitting these handlers for CodePeer is justified as follows:
3065
3066 -- If a handler is dead, then omitting it is surely ok
3067
3068 -- If a handler is live, then CodePeer should flag the
3069 -- potentially-exception-raising construct that causes it
3070 -- to be live. That is what we are interested in, not what
3071 -- happens after the exception is raised.
3072
3073 if Exceptions_OK and not CodePeer_Mode then
3074 Fin_Stmts := New_List (
3075 Make_Block_Statement (Loc,
3076 Handled_Statement_Sequence =>
3077 Make_Handled_Sequence_Of_Statements (Loc,
3078 Statements => New_List (Fin_Call),
3079
3080 Exception_Handlers => New_List (
3081 Build_Exception_Handler
3082 (Finalizer_Data, For_Package)))));
3083
3084 -- When exception handlers are prohibited, the finalization call
3085 -- appears unprotected. Any exception raised during finalization
3086 -- will bypass the circuitry which ensures the cleanup of all
3087 -- remaining objects.
3088
3089 else
3090 Fin_Stmts := New_List (Fin_Call);
3091 end if;
3092
3093 -- If we are dealing with a return object of a build-in-place
3094 -- function, generate the following cleanup statements:
3095
3096 -- if BIPallocfrom > Secondary_Stack'Pos
3097 -- and then BIPfinalizationmaster /= null
3098 -- then
3099 -- declare
3100 -- type Ptr_Typ is access Obj_Typ;
3101 -- for Ptr_Typ'Storage_Pool use
3102 -- Base_Pool (BIPfinalizationmaster.all).all;
3103 -- begin
3104 -- Free (Ptr_Typ (Temp));
3105 -- end;
3106 -- end if;
3107
3108 -- The generated code effectively detaches the temporary from the
3109 -- caller finalization master and deallocates the object.
3110
3111 if Is_Return_Object (Obj_Id) then
3112 declare
3113 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
3114 begin
3115 if Is_Build_In_Place_Function (Func_Id)
3116 and then Needs_BIP_Finalization_Master (Func_Id)
3117 then
3118 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3119 end if;
3120 end;
3121 end if;
3122
3123 if Ekind_In (Obj_Id, E_Constant, E_Variable)
3124 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3125 then
3126 -- Temporaries created for the purpose of "exporting" a
3127 -- controlled transient out of an Expression_With_Actions (EWA)
3128 -- need guards. The following illustrates the usage of such
3129 -- temporaries.
3130
3131 -- Access_Typ : access [all] Obj_Typ;
3132 -- Temp : Access_Typ := null;
3133 -- <Counter> := ...;
3134
3135 -- do
3136 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3137 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3138 -- <or>
3139 -- Temp := Ctrl_Trans'Unchecked_Access;
3140 -- in ... end;
3141
3142 -- The finalization machinery does not process EWA nodes as
3143 -- this may lead to premature finalization of expressions. Note
3144 -- that Temp is marked as being properly initialized regardless
3145 -- of whether the initialization of Ctrl_Trans succeeded. Since
3146 -- a failed initialization may leave Temp with a value of null,
3147 -- add a guard to handle this case:
3148
3149 -- if Obj /= null then
3150 -- <object finalization statements>
3151 -- end if;
3152
3153 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3154 N_Object_Declaration
3155 then
3156 Fin_Stmts := New_List (
3157 Make_If_Statement (Loc,
3158 Condition =>
3159 Make_Op_Ne (Loc,
3160 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3161 Right_Opnd => Make_Null (Loc)),
3162 Then_Statements => Fin_Stmts));
3163
3164 -- Return objects use a flag to aid in processing their
3165 -- potential finalization when the enclosing function fails
3166 -- to return properly. Generate:
3167
3168 -- if not Flag then
3169 -- <object finalization statements>
3170 -- end if;
3171
3172 else
3173 Fin_Stmts := New_List (
3174 Make_If_Statement (Loc,
3175 Condition =>
3176 Make_Op_Not (Loc,
3177 Right_Opnd =>
3178 New_Occurrence_Of
3179 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3180
3181 Then_Statements => Fin_Stmts));
3182 end if;
3183 end if;
3184 end if;
3185
3186 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3187
3188 -- Since the declarations are examined in reverse, the state counter
3189 -- must be decremented in order to keep with the true position of
3190 -- objects.
3191
3192 Counter_Val := Counter_Val - 1;
3193 end Process_Object_Declaration;
3194
3195 -------------------------------------
3196 -- Process_Tagged_Type_Declaration --
3197 -------------------------------------
3198
3199 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3200 Typ : constant Entity_Id := Defining_Identifier (Decl);
3201 DT_Ptr : constant Entity_Id :=
3202 Node (First_Elmt (Access_Disp_Table (Typ)));
3203 begin
3204 -- Generate:
3205 -- Ada.Tags.Unregister_Tag (<Typ>P);
3206
3207 Append_To (Tagged_Type_Stmts,
3208 Make_Procedure_Call_Statement (Loc,
3209 Name =>
3210 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3211 Parameter_Associations => New_List (
3212 New_Occurrence_Of (DT_Ptr, Loc))));
3213 end Process_Tagged_Type_Declaration;
3214
3215 -- Start of processing for Build_Finalizer
3216
3217 begin
3218 Fin_Id := Empty;
3219
3220 -- Do not perform this expansion in SPARK mode because it is not
3221 -- necessary.
3222
3223 if GNATprove_Mode then
3224 return;
3225 end if;
3226
3227 -- Step 1: Extract all lists which may contain controlled objects or
3228 -- library-level tagged types.
3229
3230 if For_Package_Spec then
3231 Decls := Visible_Declarations (Specification (N));
3232 Priv_Decls := Private_Declarations (Specification (N));
3233
3234 -- Retrieve the package spec id
3235
3236 Spec_Id := Defining_Unit_Name (Specification (N));
3237
3238 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3239 Spec_Id := Defining_Identifier (Spec_Id);
3240 end if;
3241
3242 -- Accept statement, block, entry body, package body, protected body,
3243 -- subprogram body or task body.
3244
3245 else
3246 Decls := Declarations (N);
3247 HSS := Handled_Statement_Sequence (N);
3248
3249 if Present (HSS) then
3250 if Present (Statements (HSS)) then
3251 Stmts := Statements (HSS);
3252 end if;
3253
3254 if Present (At_End_Proc (HSS)) then
3255 Prev_At_End := At_End_Proc (HSS);
3256 end if;
3257 end if;
3258
3259 -- Retrieve the package spec id for package bodies
3260
3261 if For_Package_Body then
3262 Spec_Id := Corresponding_Spec (N);
3263 end if;
3264 end if;
3265
3266 -- Do not process nested packages since those are handled by the
3267 -- enclosing scope's finalizer. Do not process non-expanded package
3268 -- instantiations since those will be re-analyzed and re-expanded.
3269
3270 if For_Package
3271 and then
3272 (not Is_Library_Level_Entity (Spec_Id)
3273
3274 -- Nested packages are considered to be library level entities,
3275 -- but do not need to be processed separately. True library level
3276 -- packages have a scope value of 1.
3277
3278 or else Scope_Depth_Value (Spec_Id) /= Uint_1
3279 or else (Is_Generic_Instance (Spec_Id)
3280 and then Package_Instantiation (Spec_Id) /= N))
3281 then
3282 return;
3283 end if;
3284
3285 -- Step 2: Object [pre]processing
3286
3287 if For_Package then
3288
3289 -- Preprocess the visible declarations now in order to obtain the
3290 -- correct number of controlled object by the time the private
3291 -- declarations are processed.
3292
3293 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3294
3295 -- From all the possible contexts, only package specifications may
3296 -- have private declarations.
3297
3298 if For_Package_Spec then
3299 Process_Declarations
3300 (Priv_Decls, Preprocess => True, Top_Level => True);
3301 end if;
3302
3303 -- The current context may lack controlled objects, but require some
3304 -- other form of completion (task termination for instance). In such
3305 -- cases, the finalizer must be created and carry the additional
3306 -- statements.
3307
3308 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3309 Build_Components;
3310 end if;
3311
3312 -- The preprocessing has determined that the context has controlled
3313 -- objects or library-level tagged types.
3314
3315 if Has_Ctrl_Objs or Has_Tagged_Types then
3316
3317 -- Private declarations are processed first in order to preserve
3318 -- possible dependencies between public and private objects.
3319
3320 if For_Package_Spec then
3321 Process_Declarations (Priv_Decls);
3322 end if;
3323
3324 Process_Declarations (Decls);
3325 end if;
3326
3327 -- Non-package case
3328
3329 else
3330 -- Preprocess both declarations and statements
3331
3332 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3333 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3334
3335 -- At this point it is known that N has controlled objects. Ensure
3336 -- that N has a declarative list since the finalizer spec will be
3337 -- attached to it.
3338
3339 if Has_Ctrl_Objs and then No (Decls) then
3340 Set_Declarations (N, New_List);
3341 Decls := Declarations (N);
3342 Spec_Decls := Decls;
3343 end if;
3344
3345 -- The current context may lack controlled objects, but require some
3346 -- other form of completion (task termination for instance). In such
3347 -- cases, the finalizer must be created and carry the additional
3348 -- statements.
3349
3350 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3351 Build_Components;
3352 end if;
3353
3354 if Has_Ctrl_Objs or Has_Tagged_Types then
3355 Process_Declarations (Stmts);
3356 Process_Declarations (Decls);
3357 end if;
3358 end if;
3359
3360 -- Step 3: Finalizer creation
3361
3362 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3363 Create_Finalizer;
3364 end if;
3365 end Build_Finalizer;
3366
3367 --------------------------
3368 -- Build_Finalizer_Call --
3369 --------------------------
3370
3371 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3372 Is_Prot_Body : constant Boolean :=
3373 Nkind (N) = N_Subprogram_Body
3374 and then Is_Protected_Subprogram_Body (N);
3375 -- Determine whether N denotes the protected version of a subprogram
3376 -- which belongs to a protected type.
3377
3378 Loc : constant Source_Ptr := Sloc (N);
3379 HSS : Node_Id;
3380
3381 begin
3382 -- Do not perform this expansion in SPARK mode because we do not create
3383 -- finalizers in the first place.
3384
3385 if GNATprove_Mode then
3386 return;
3387 end if;
3388
3389 -- The At_End handler should have been assimilated by the finalizer
3390
3391 HSS := Handled_Statement_Sequence (N);
3392 pragma Assert (No (At_End_Proc (HSS)));
3393
3394 -- If the construct to be cleaned up is a protected subprogram body, the
3395 -- finalizer call needs to be associated with the block which wraps the
3396 -- unprotected version of the subprogram. The following illustrates this
3397 -- scenario:
3398
3399 -- procedure Prot_SubpP is
3400 -- procedure finalizer is
3401 -- begin
3402 -- Service_Entries (Prot_Obj);
3403 -- Abort_Undefer;
3404 -- end finalizer;
3405
3406 -- begin
3407 -- . . .
3408 -- begin
3409 -- Prot_SubpN (Prot_Obj);
3410 -- at end
3411 -- finalizer;
3412 -- end;
3413 -- end Prot_SubpP;
3414
3415 if Is_Prot_Body then
3416 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3417
3418 -- An At_End handler and regular exception handlers cannot coexist in
3419 -- the same statement sequence. Wrap the original statements in a block.
3420
3421 elsif Present (Exception_Handlers (HSS)) then
3422 declare
3423 End_Lab : constant Node_Id := End_Label (HSS);
3424 Block : Node_Id;
3425
3426 begin
3427 Block :=
3428 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3429
3430 Set_Handled_Statement_Sequence (N,
3431 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3432
3433 HSS := Handled_Statement_Sequence (N);
3434 Set_End_Label (HSS, End_Lab);
3435 end;
3436 end if;
3437
3438 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3439
3440 Analyze (At_End_Proc (HSS));
3441 Expand_At_End_Handler (HSS, Empty);
3442 end Build_Finalizer_Call;
3443
3444 ------------------------------------
3445 -- Build_Invariant_Procedure_Body --
3446 ------------------------------------
3447
3448 procedure Build_Invariant_Procedure_Body
3449 (Typ : Entity_Id;
3450 Partial_Invariant : Boolean := False)
3451 is
3452 Loc : constant Source_Ptr := Sloc (Typ);
3453
3454 Pragmas_Seen : Elist_Id := No_Elist;
3455 -- This list contains all invariant pragmas processed so far. The list
3456 -- is used to avoid generating redundant invariant checks.
3457
3458 Produced_Check : Boolean := False;
3459 -- This flag tracks whether the type has produced at least one invariant
3460 -- check. The flag is used as a sanity check at the end of the routine.
3461
3462 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
3463 -- intentionally unnested to avoid deep indentation of code.
3464
3465 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
3466 -- they emit checks, loops (for arrays) and case statements (for record
3467 -- variant parts) only when there are invariants to verify. This keeps
3468 -- the body of the invariant procedure free from useless code.
3469
3470 procedure Add_Array_Component_Invariants
3471 (T : Entity_Id;
3472 Obj_Id : Entity_Id;
3473 Checks : in out List_Id);
3474 -- Generate an invariant check for each component of array type T.
3475 -- Obj_Id denotes the entity of the _object formal parameter of the
3476 -- invariant procedure. All created checks are added to list Checks.
3477
3478 procedure Add_Interface_Invariants
3479 (T : Entity_Id;
3480 Obj_Id : Entity_Id;
3481 Checks : in out List_Id);
3482 -- Generate an invariant check for each inherited class-wide invariant
3483 -- coming from all interfaces implemented by type T. Obj_Id denotes the
3484 -- entity of the _object formal parameter of the invariant procedure.
3485 -- All created checks are added to list Checks.
3486
3487 procedure Add_Parent_Invariants
3488 (T : Entity_Id;
3489 Obj_Id : Entity_Id;
3490 Checks : in out List_Id);
3491 -- Generate an invariant check for each inherited class-wide invariant
3492 -- coming from all parent types of type T. Obj_Id denotes the entity of
3493 -- the _object formal parameter of the invariant procedure. All created
3494 -- checks are added to list Checks.
3495
3496 procedure Add_Record_Component_Invariants
3497 (T : Entity_Id;
3498 Obj_Id : Entity_Id;
3499 Checks : in out List_Id);
3500 -- Generate an invariant check for each component of record type T.
3501 -- Obj_Id denotes the entity of the _object formal parameter of the
3502 -- invariant procedure. All created checks are added to list Checks.
3503
3504 procedure Add_Type_Invariants
3505 (Priv_Typ : Entity_Id;
3506 Full_Typ : Entity_Id;
3507 CRec_Typ : Entity_Id;
3508 Obj_Id : Entity_Id;
3509 Checks : in out List_Id;
3510 Inherit : Boolean := False;
3511 Priv_Item : Node_Id := Empty);
3512 -- Generate an invariant check for each invariant found in one of the
3513 -- following types (if available):
3514 --
3515 -- Priv_Typ - the partial view of a type
3516 -- Full_Typ - the full view of a type
3517 -- CRec_Typ - the corresponding record of a protected or a task type
3518 --
3519 -- Obj_Id denotes the entity of the _object formal parameter of the
3520 -- invariant procedure. All created checks are added to list Checks.
3521 -- Flag Inherit should be set when generating invariant checks for
3522 -- inherited class-wide invariants. Priv_Item denotes the first rep
3523 -- item of the private type.
3524
3525 procedure Create_Append (L : in out List_Id; N : Node_Id);
3526 -- Append arbitrary node N to list L. If there is no list, create one.
3527
3528 function Is_Untagged_Private_Derivation
3529 (Priv_Typ : Entity_Id;
3530 Full_Typ : Entity_Id) return Boolean;
3531 -- Determine whether private type Priv_Typ and its full view Full_Typ
3532 -- represent an untagged derivation from a private parent.
3533
3534 ------------------------------------
3535 -- Add_Array_Component_Invariants --
3536 ------------------------------------
3537
3538 procedure Add_Array_Component_Invariants
3539 (T : Entity_Id;
3540 Obj_Id : Entity_Id;
3541 Checks : in out List_Id)
3542 is
3543 Comp_Typ : constant Entity_Id := Component_Type (T);
3544 Dims : constant Pos := Number_Dimensions (T);
3545
3546 procedure Process_Array_Component
3547 (Indices : List_Id;
3548 Comp_Checks : in out List_Id);
3549 -- Generate an invariant check for an array component identified by
3550 -- the indices in list Indices. All created checks are added to list
3551 -- Comp_Checks.
3552
3553 procedure Process_One_Dimension
3554 (Dim : Pos;
3555 Indices : List_Id;
3556 Dim_Checks : in out List_Id);
3557 -- Generate a loop over the Nth dimension Dim of an array type. List
3558 -- Indices contains all array indices for the dimension. All created
3559 -- checks are added to list Dim_Checks.
3560
3561 -----------------------------
3562 -- Process_Array_Component --
3563 -----------------------------
3564
3565 procedure Process_Array_Component
3566 (Indices : List_Id;
3567 Comp_Checks : in out List_Id)
3568 is
3569 Proc_Id : Entity_Id;
3570
3571 begin
3572 if Has_Invariants (Comp_Typ) then
3573 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3574
3575 -- The component type should have an invariant procedure if it
3576 -- has invariants of its own or inherits class-wide invariants
3577 -- from parent or interface types.
3578
3579 pragma Assert (Present (Proc_Id));
3580
3581 -- Generate:
3582 -- <Comp_Typ>Invariant (_object (<Indices>));
3583
3584 -- Note that the invariant procedure may have a null body if
3585 -- assertions are disabled or Assertion_Polity Ignore is in
3586 -- effect.
3587
3588 if not Has_Null_Body (Proc_Id) then
3589 Create_Append (Comp_Checks,
3590 Make_Procedure_Call_Statement (Loc,
3591 Name =>
3592 New_Occurrence_Of (Proc_Id, Loc),
3593 Parameter_Associations => New_List (
3594 Make_Indexed_Component (Loc,
3595 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3596 Expressions => New_Copy_List (Indices)))));
3597 end if;
3598
3599 Produced_Check := True;
3600 end if;
3601
3602 -- In a rare case the designated type of an access component may
3603 -- have an invariant. In this case verify the dereference of the
3604 -- component.
3605
3606 if Is_Access_Type (Comp_Typ)
3607 and then Has_Invariants (Designated_Type (Comp_Typ))
3608 then
3609 Proc_Id :=
3610 Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ)));
3611
3612 -- The designated type should have an invariant procedure if it
3613 -- has invariants of its own or inherits class-wide invariants
3614 -- from parent or interface types.
3615
3616 pragma Assert (Present (Proc_Id));
3617
3618 -- Generate:
3619 -- if _object (<Indexes>) /= null then
3620 -- <Desig_Comp_Typ>Invariant (_object (<Indices>).all);
3621 -- end if;
3622
3623 -- Note that the invariant procedure may have a null body if
3624 -- assertions are disabled or Assertion_Polity Ignore is in
3625 -- effect.
3626
3627 if not Has_Null_Body (Proc_Id) then
3628 Create_Append (Comp_Checks,
3629 Make_If_Statement (Loc,
3630 Condition =>
3631 Make_Op_Ne (Loc,
3632 Left_Opnd =>
3633 Make_Indexed_Component (Loc,
3634 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3635 Expressions => New_Copy_List (Indices)),
3636 Right_Opnd => Make_Null (Loc)),
3637
3638 Then_Statements => New_List (
3639 Make_Procedure_Call_Statement (Loc,
3640 Name =>
3641 New_Occurrence_Of (Proc_Id, Loc),
3642
3643 Parameter_Associations => New_List (
3644 Make_Explicit_Dereference (Loc,
3645 Prefix =>
3646 Make_Indexed_Component (Loc,
3647 Prefix =>
3648 New_Occurrence_Of (Obj_Id, Loc),
3649 Expressions =>
3650 New_Copy_List (Indices))))))));
3651 end if;
3652
3653 Produced_Check := True;
3654 end if;
3655 end Process_Array_Component;
3656
3657 ---------------------------
3658 -- Process_One_Dimension --
3659 ---------------------------
3660
3661 procedure Process_One_Dimension
3662 (Dim : Pos;
3663 Indices : List_Id;
3664 Dim_Checks : in out List_Id)
3665 is
3666 Comp_Checks : List_Id := No_List;
3667 Index : Entity_Id;
3668
3669 begin
3670 -- Generate the invariant checks for the array component after all
3671 -- dimensions have produced their respective loops.
3672
3673 if Dim > Dims then
3674 Process_Array_Component
3675 (Indices => Indices,
3676 Comp_Checks => Dim_Checks);
3677
3678 -- Otherwise create a loop for the current dimension
3679
3680 else
3681 -- Create a new loop variable for each dimension
3682
3683 Index :=
3684 Make_Defining_Identifier (Loc,
3685 Chars => New_External_Name ('I', Dim));
3686 Append_To (Indices, New_Occurrence_Of (Index, Loc));
3687
3688 Process_One_Dimension
3689 (Dim => Dim + 1,
3690 Indices => Indices,
3691 Dim_Checks => Comp_Checks);
3692
3693 -- Generate:
3694 -- for I<Dim> in _object'Range (<Dim>) loop
3695 -- <Comp_Checks>
3696 -- end loop;
3697
3698 -- Note that the invariant procedure may have a null body if
3699 -- assertions are disabled or Assertion_Polity Ignore is in
3700 -- effect.
3701
3702 if Present (Comp_Checks) then
3703 Create_Append (Dim_Checks,
3704 Make_Implicit_Loop_Statement (T,
3705 Identifier => Empty,
3706 Iteration_Scheme =>
3707 Make_Iteration_Scheme (Loc,
3708 Loop_Parameter_Specification =>
3709 Make_Loop_Parameter_Specification (Loc,
3710 Defining_Identifier => Index,
3711 Discrete_Subtype_Definition =>
3712 Make_Attribute_Reference (Loc,
3713 Prefix =>
3714 New_Occurrence_Of (Obj_Id, Loc),
3715 Attribute_Name => Name_Range,
3716 Expressions => New_List (
3717 Make_Integer_Literal (Loc, Dim))))),
3718
3719 Statements => Comp_Checks));
3720 end if;
3721 end if;
3722 end Process_One_Dimension;
3723
3724 -- Start of processing for Add_Array_Component_Invariants
3725
3726 begin
3727 Process_One_Dimension
3728 (Dim => 1,
3729 Indices => New_List,
3730 Dim_Checks => Checks);
3731 end Add_Array_Component_Invariants;
3732
3733 ------------------------------
3734 -- Add_Interface_Invariants --
3735 ------------------------------
3736
3737 procedure Add_Interface_Invariants
3738 (T : Entity_Id;
3739 Obj_Id : Entity_Id;
3740 Checks : in out List_Id)
3741 is
3742 Iface_Elmt : Elmt_Id;
3743 Ifaces : Elist_Id;
3744
3745 begin
3746 if Is_Tagged_Type (T) then
3747 Collect_Interfaces (T, Ifaces);
3748
3749 -- Process the class-wide invariants of all implemented interfaces
3750
3751 Iface_Elmt := First_Elmt (Ifaces);
3752 while Present (Iface_Elmt) loop
3753 Add_Type_Invariants
3754 (Priv_Typ => Empty,
3755 Full_Typ => Node (Iface_Elmt),
3756 CRec_Typ => Empty,
3757 Obj_Id => Obj_Id,
3758 Checks => Checks,
3759 Inherit => True);
3760
3761 Next_Elmt (Iface_Elmt);
3762 end loop;
3763 end if;
3764 end Add_Interface_Invariants;
3765
3766 ---------------------------
3767 -- Add_Parent_Invariants --
3768 ---------------------------
3769
3770 procedure Add_Parent_Invariants
3771 (T : Entity_Id;
3772 Obj_Id : Entity_Id;
3773 Checks : in out List_Id)
3774 is
3775 Dummy_1 : Entity_Id;
3776 Dummy_2 : Entity_Id;
3777
3778 Curr_Typ : Entity_Id;
3779 -- The entity of the current type being examined
3780
3781 Full_Typ : Entity_Id;
3782 -- The full view of Par_Typ
3783
3784 Par_Typ : Entity_Id;
3785 -- The entity of the parent type
3786
3787 Priv_Typ : Entity_Id;
3788 -- The partial view of Par_Typ
3789
3790 begin
3791 -- Climb the parent type chain
3792
3793 Curr_Typ := T;
3794 loop
3795 -- Do not consider subtypes as they inherit the invariants from
3796 -- their base types.
3797
3798 Par_Typ := Base_Type (Etype (Curr_Typ));
3799
3800 -- Stop the climb once the root of the parent chain is reached
3801
3802 exit when Curr_Typ = Par_Typ;
3803
3804 -- Process the class-wide invariants of the parent type
3805
3806 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
3807
3808 Add_Type_Invariants
3809 (Priv_Typ => Priv_Typ,
3810 Full_Typ => Full_Typ,
3811 CRec_Typ => Empty,
3812 Obj_Id => Obj_Id,
3813 Checks => Checks,
3814 Inherit => True);
3815
3816 Curr_Typ := Par_Typ;
3817 end loop;
3818 end Add_Parent_Invariants;
3819
3820 -------------------------------------
3821 -- Add_Record_Component_Invariants --
3822 -------------------------------------
3823
3824 procedure Add_Record_Component_Invariants
3825 (T : Entity_Id;
3826 Obj_Id : Entity_Id;
3827 Checks : in out List_Id)
3828 is
3829 procedure Process_Component_List
3830 (Comp_List : Node_Id;
3831 CL_Checks : in out List_Id);
3832 -- Generate invariant checks for all record components found in
3833 -- component list Comp_List, including variant parts. All created
3834 -- checks are added to list CL_Checks.
3835
3836 procedure Process_Record_Component
3837 (Comp_Id : Entity_Id;
3838 Comp_Checks : in out List_Id);
3839 -- Generate an invariant check for a record component identified by
3840 -- Comp_Id. All created checks are added to list Comp_Checks.
3841
3842 ----------------------------
3843 -- Process_Component_List --
3844 ----------------------------
3845
3846 procedure Process_Component_List
3847 (Comp_List : Node_Id;
3848 CL_Checks : in out List_Id)
3849 is
3850 Comp : Node_Id;
3851 Var : Node_Id;
3852 Var_Alts : List_Id := No_List;
3853 Var_Checks : List_Id := No_List;
3854 Var_Stmts : List_Id;
3855
3856 Produced_Variant_Check : Boolean := False;
3857 -- This flag tracks whether the component has produced at least
3858 -- one invariant check.
3859
3860 begin
3861 -- Traverse the component items
3862
3863 Comp := First (Component_Items (Comp_List));
3864 while Present (Comp) loop
3865 if Nkind (Comp) = N_Component_Declaration then
3866
3867 -- Generate the component invariant check
3868
3869 Process_Record_Component
3870 (Comp_Id => Defining_Entity (Comp),
3871 Comp_Checks => CL_Checks);
3872 end if;
3873
3874 Next (Comp);
3875 end loop;
3876
3877 -- Traverse the variant part
3878
3879 if Present (Variant_Part (Comp_List)) then
3880 Var := First (Variants (Variant_Part (Comp_List)));
3881 while Present (Var) loop
3882 Var_Checks := No_List;
3883
3884 -- Generate invariant checks for all components and variant
3885 -- parts that qualify.
3886
3887 Process_Component_List
3888 (Comp_List => Component_List (Var),
3889 CL_Checks => Var_Checks);
3890
3891 -- The components of the current variant produced at least
3892 -- one invariant check.
3893
3894 if Present (Var_Checks) then
3895 Var_Stmts := Var_Checks;
3896 Produced_Variant_Check := True;
3897
3898 -- Otherwise there are either no components with invariants,
3899 -- assertions are disabled, or Assertion_Policy Ignore is in
3900 -- effect.
3901
3902 else
3903 Var_Stmts := New_List (Make_Null_Statement (Loc));
3904 end if;
3905
3906 Create_Append (Var_Alts,
3907 Make_Case_Statement_Alternative (Loc,
3908 Discrete_Choices =>
3909 New_Copy_List (Discrete_Choices (Var)),
3910 Statements => Var_Stmts));
3911
3912 Next (Var);
3913 end loop;
3914
3915 -- Create a case statement which verifies the invariant checks
3916 -- of a particular component list depending on the discriminant
3917 -- values only when there is at least one real invariant check.
3918
3919 if Produced_Variant_Check then
3920 Create_Append (CL_Checks,
3921 Make_Case_Statement (Loc,
3922 Expression =>
3923 Make_Selected_Component (Loc,
3924 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3925 Selector_Name =>
3926 New_Occurrence_Of
3927 (Entity (Name (Variant_Part (Comp_List))), Loc)),
3928 Alternatives => Var_Alts));
3929 end if;
3930 end if;
3931 end Process_Component_List;
3932
3933 ------------------------------
3934 -- Process_Record_Component --
3935 ------------------------------
3936
3937 procedure Process_Record_Component
3938 (Comp_Id : Entity_Id;
3939 Comp_Checks : in out List_Id)
3940 is
3941 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
3942 Proc_Id : Entity_Id;
3943
3944 Produced_Component_Check : Boolean := False;
3945 -- This flag tracks whether the component has produced at least
3946 -- one invariant check.
3947
3948 begin
3949 -- Nothing to do for internal component _parent. Note that it is
3950 -- not desirable to check whether the component comes from source
3951 -- because protected type components are relocated to an internal
3952 -- corresponding record, but still need processing.
3953
3954 if Chars (Comp_Id) = Name_uParent then
3955 return;
3956 end if;
3957
3958 -- Verify the invariant of the component. Note that an access
3959 -- type may have an invariant when it acts as the full view of a
3960 -- private type and the invariant appears on the partial view. In
3961 -- this case verify the access value itself.
3962
3963 if Has_Invariants (Comp_Typ) then
3964 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3965
3966 -- The component type should have an invariant procedure if it
3967 -- has invariants of its own or inherits class-wide invariants
3968 -- from parent or interface types.
3969
3970 pragma Assert (Present (Proc_Id));
3971
3972 -- Generate:
3973 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
3974
3975 -- Note that the invariant procedure may have a null body if
3976 -- assertions are disabled or Assertion_Polity Ignore is in
3977 -- effect.
3978
3979 if not Has_Null_Body (Proc_Id) then
3980 Create_Append (Comp_Checks,
3981 Make_Procedure_Call_Statement (Loc,
3982 Name =>
3983 New_Occurrence_Of (Proc_Id, Loc),
3984 Parameter_Associations => New_List (
3985 Make_Selected_Component (Loc,
3986 Prefix =>
3987 Unchecked_Convert_To
3988 (T, New_Occurrence_Of (Obj_Id, Loc)),
3989 Selector_Name =>
3990 New_Occurrence_Of (Comp_Id, Loc)))));
3991 end if;
3992
3993 Produced_Check := True;
3994 Produced_Component_Check := True;
3995 end if;
3996
3997 -- In a rare case the designated type of an access component may
3998 -- have a invariant. In this case verify the dereference of the
3999 -- component.
4000
4001 if Is_Access_Type (Comp_Typ)
4002 and then Has_Invariants (Designated_Type (Comp_Typ))
4003 then
4004 Proc_Id :=
4005 Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ)));
4006
4007 -- The designated type should have an invariant procedure if it
4008 -- has invariants of its own or inherits class-wide invariants
4009 -- from parent or interface types.
4010
4011 pragma Assert (Present (Proc_Id));
4012
4013 -- Generate:
4014 -- if T (_object).<Comp_Id> /= null then
4015 -- <Desig_Comp_Typ>Invariant (T (_object).<Comp_Id>.all);
4016 -- end if;
4017
4018 -- Note that the invariant procedure may have a null body if
4019 -- assertions are disabled or Assertion_Polity Ignore is in
4020 -- effect.
4021
4022 if not Has_Null_Body (Proc_Id) then
4023 Create_Append (Comp_Checks,
4024 Make_If_Statement (Loc,
4025 Condition =>
4026 Make_Op_Ne (Loc,
4027 Left_Opnd =>
4028 Make_Selected_Component (Loc,
4029 Prefix =>
4030 Unchecked_Convert_To
4031 (T, New_Occurrence_Of (Obj_Id, Loc)),
4032 Selector_Name =>
4033 New_Occurrence_Of (Comp_Id, Loc)),
4034 Right_Opnd => Make_Null (Loc)),
4035
4036 Then_Statements => New_List (
4037 Make_Procedure_Call_Statement (Loc,
4038 Name =>
4039 New_Occurrence_Of (Proc_Id, Loc),
4040
4041 Parameter_Associations => New_List (
4042 Make_Explicit_Dereference (Loc,
4043 Prefix =>
4044 Make_Selected_Component (Loc,
4045 Prefix =>
4046 Unchecked_Convert_To
4047 (T, New_Occurrence_Of (Obj_Id, Loc)),
4048 Selector_Name =>
4049 New_Occurrence_Of (Comp_Id, Loc))))))));
4050 end if;
4051
4052 Produced_Check := True;
4053 Produced_Component_Check := True;
4054 end if;
4055
4056 if Produced_Component_Check and then Has_Unchecked_Union (T) then
4057 Error_Msg_NE
4058 ("invariants cannot be checked on components of "
4059 & "unchecked_union type &?", Comp_Id, T);
4060 end if;
4061 end Process_Record_Component;
4062
4063 -- Local variables
4064
4065 Comps : Node_Id;
4066 Def : Node_Id;
4067
4068 -- Start of processing for Add_Record_Component_Invariants
4069
4070 begin
4071 -- An untagged derived type inherits the components of its parent
4072 -- type. In order to avoid creating redundant invariant checks, do
4073 -- not process the components now. Instead wait until the ultimate
4074 -- parent of the untagged derivation chain is reached.
4075
4076 if not Is_Untagged_Derivation (T) then
4077 Def := Type_Definition (Parent (T));
4078
4079 if Nkind (Def) = N_Derived_Type_Definition then
4080 Def := Record_Extension_Part (Def);
4081 end if;
4082
4083 pragma Assert (Nkind (Def) = N_Record_Definition);
4084 Comps := Component_List (Def);
4085
4086 if Present (Comps) then
4087 Process_Component_List
4088 (Comp_List => Comps,
4089 CL_Checks => Checks);
4090 end if;
4091 end if;
4092 end Add_Record_Component_Invariants;
4093
4094 -------------------------
4095 -- Add_Type_Invariants --
4096 -------------------------
4097
4098 procedure Add_Type_Invariants
4099 (Priv_Typ : Entity_Id;
4100 Full_Typ : Entity_Id;
4101 CRec_Typ : Entity_Id;
4102 Obj_Id : Entity_Id;
4103 Checks : in out List_Id;
4104 Inherit : Boolean := False;
4105 Priv_Item : Node_Id := Empty)
4106 is
4107 procedure Add_Invariant (Prag : Node_Id);
4108 -- Create a runtime check to verify the invariant exression of pragma
4109 -- Prag. All generated code is added to list Checks.
4110
4111 procedure Process_Type (T : Entity_Id; Stop_Item : Node_Id := Empty);
4112 -- Generate invariant checks for type T by inspecting the rep item
4113 -- chain of the type. Stop_Item denotes a rep item which once seen
4114 -- will stop the inspection.
4115
4116 -------------------
4117 -- Add_Invariant --
4118 -------------------
4119
4120 procedure Add_Invariant (Prag : Node_Id) is
4121 Rep_Typ : Entity_Id;
4122 -- The replacement type used in the substitution of the current
4123 -- instance of a type with the _object formal parameter.
4124
4125 procedure Replace_Type_Ref (N : Node_Id);
4126 -- Substitute the occurrence of a type name denoted by N with a
4127 -- reference to the _object formal parameter.
4128
4129 ----------------------
4130 -- Replace_Type_Ref --
4131 ----------------------
4132
4133 procedure Replace_Type_Ref (N : Node_Id) is
4134 Nloc : constant Source_Ptr := Sloc (N);
4135 Ref : Node_Id;
4136
4137 begin
4138 -- Decorate the reference to Ref_Typ even though it may be
4139 -- rewritten further down. This is done for two reasons:
4140
4141 -- 1) ASIS has all necessary semantic information in the
4142 -- original tree.
4143
4144 -- 2) Routines which examine properties of the Original_Node
4145 -- have some semantic information.
4146
4147 if Nkind (N) = N_Identifier then
4148 Set_Entity (N, Rep_Typ);
4149 Set_Etype (N, Rep_Typ);
4150
4151 elsif Nkind (N) = N_Selected_Component then
4152 Analyze (Prefix (N));
4153 Set_Entity (Selector_Name (N), Rep_Typ);
4154 Set_Etype (Selector_Name (N), Rep_Typ);
4155 end if;
4156
4157 -- Perform the following substitution:
4158
4159 -- Ref_Typ --> _object
4160
4161 Ref := Make_Identifier (Nloc, Chars (Obj_Id));
4162 Set_Entity (Ref, Obj_Id);
4163 Set_Etype (Ref, Rep_Typ);
4164
4165 -- When the pragma denotes a class-wide invariant, perform the
4166 -- following substitution:
4167
4168 -- Rep_Typ --> Rep_Typ'Class (_object)
4169
4170 if Class_Present (Prag) then
4171 Ref :=
4172 Make_Type_Conversion (Nloc,
4173 Subtype_Mark =>
4174 Make_Attribute_Reference (Nloc,
4175 Prefix =>
4176 New_Occurrence_Of (Rep_Typ, Nloc),
4177 Attribute_Name => Name_Class),
4178 Expression => Ref);
4179 end if;
4180
4181 Rewrite (N, Ref);
4182 Set_Comes_From_Source (N, True);
4183 end Replace_Type_Ref;
4184
4185 procedure Replace_Type_Refs is
4186 new Replace_Type_References_Generic (Replace_Type_Ref);
4187
4188 -- Local variables
4189
4190 Asp : constant Node_Id := Corresponding_Aspect (Prag);
4191 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
4192 Ploc : constant Source_Ptr := Sloc (Prag);
4193
4194 Arg1 : Node_Id;
4195 Arg2 : Node_Id;
4196 Arg3 : Node_Id;
4197 ASIS_Expr : Node_Id;
4198 Assoc : List_Id;
4199 Expr : Node_Id;
4200 Str : String_Id;
4201
4202 -- Start of processing for Add_Invariant
4203
4204 begin
4205 -- Nothing to do if the pragma was already processed
4206
4207 if Contains (Pragmas_Seen, Prag) then
4208 return;
4209 end if;
4210
4211 -- Extract the arguments of the invariant pragma
4212
4213 Arg1 := First (Pragma_Argument_Associations (Prag));
4214 Arg2 := Next (Arg1);
4215 Arg3 := Next (Arg2);
4216
4217 Arg1 := Get_Pragma_Arg (Arg1);
4218 Arg2 := Get_Pragma_Arg (Arg2);
4219
4220 -- The pragma applies to the partial view
4221
4222 if Present (Priv_Typ) and then Entity (Arg1) = Priv_Typ then
4223 Rep_Typ := Priv_Typ;
4224
4225 -- The pragma applies to the full view
4226
4227 elsif Present (Full_Typ) and then Entity (Arg1) = Full_Typ then
4228 Rep_Typ := Full_Typ;
4229
4230 -- Otherwise the pragma applies to a parent type in which case it
4231 -- will be processed at a later stage by Add_Parent_Invariants or
4232 -- Add_Interface_Invariants.
4233
4234 else
4235 return;
4236 end if;
4237
4238 -- Nothing to do when the caller requests the processing of all
4239 -- inherited class-wide invariants, but the pragma does not fall
4240 -- in this category.
4241
4242 if Inherit and then not Class_Present (Prag) then
4243 return;
4244 end if;
4245
4246 Expr := New_Copy_Tree (Arg2);
4247
4248 -- Substitute all references to type Rep_Typ with references to
4249 -- the _object formal parameter.
4250
4251 Replace_Type_Refs (Expr, Rep_Typ);
4252
4253 -- Additional processing for non-class-wide invariants
4254
4255 if not Inherit then
4256
4257 -- Preanalyze the invariant expression to detect errors and at
4258 -- the same time capture the visibility of the proper package
4259 -- part.
4260
4261 -- Historical note: the old implementation of invariants used
4262 -- node N as the parent, but a package specification as parent
4263 -- of an expression is bizarre.
4264
4265 Set_Parent (Expr, Parent (Arg2));
4266 Preanalyze_Assert_Expression (Expr, Any_Boolean);
4267
4268 -- If the pragma comes from an aspect specification, replace
4269 -- the saved expression because all type references must be
4270 -- substituted for the call to Preanalyze_Spec_Expression in
4271 -- Check_Aspect_At_xxx routines.
4272
4273 if Present (Asp) then
4274 Set_Entity (Identifier (Asp), New_Copy_Tree (Expr));
4275 end if;
4276
4277 -- Analyze the original invariant expression for ASIS
4278
4279 if ASIS_Mode then
4280 ASIS_Expr := Empty;
4281
4282 if Comes_From_Source (Prag) then
4283 ASIS_Expr := Arg2;
4284 elsif Present (Asp) then
4285 ASIS_Expr := Expression (Asp);
4286 end if;
4287
4288 if Present (ASIS_Expr) then
4289 Replace_Type_Refs (ASIS_Expr, Rep_Typ);
4290 Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean);
4291 end if;
4292 end if;
4293
4294 -- A class-wide invariant may be inherited in a separate unit,
4295 -- where the corresponding expression cannot be resolved by
4296 -- visibility, because it refers to a local function. Propagate
4297 -- semantic information to the original representation item, to
4298 -- be used when an invariant procedure for a derived type is
4299 -- constructed.
4300
4301 -- ??? Unclear how to handle class-wide invariants that are not
4302 -- function calls.
4303
4304 if Class_Present (Prag)
4305 and then Nkind (Expr) = N_Function_Call
4306 and then Nkind (Arg2) = N_Indexed_Component
4307 then
4308 Rewrite (Arg2,
4309 Make_Function_Call (Ploc,
4310 Name =>
4311 New_Occurrence_Of (Entity (Name (Expr)), Ploc),
4312 Parameter_Associations => Expressions (Arg2)));
4313 end if;
4314 end if;
4315
4316 -- The invariant is ignored, nothing left to do
4317
4318 if Is_Ignored (Prag) then
4319 null;
4320
4321 -- Otherwise the invariant is checked. Build a Check pragma to
4322 -- verify the expression at runtime.
4323
4324 else
4325 Assoc := New_List (
4326 Make_Pragma_Argument_Association (Ploc,
4327 Expression => Make_Identifier (Ploc, Nam)),
4328 Make_Pragma_Argument_Association (Ploc,
4329 Expression => Expr));
4330
4331 -- Handle the String argument (if any)
4332
4333 if Present (Arg3) then
4334 Str := Strval (Get_Pragma_Arg (Arg3));
4335
4336 -- When inheriting an invariant, modify the message from
4337 -- "failed invariant" to "failed inherited invariant".
4338
4339 if Inherit then
4340 String_To_Name_Buffer (Str);
4341
4342 if Name_Buffer (1 .. 16) = "failed invariant" then
4343 Insert_Str_In_Name_Buffer ("inherited ", 8);
4344 Str := String_From_Name_Buffer;
4345 end if;
4346 end if;
4347
4348 Append_To (Assoc,
4349 Make_Pragma_Argument_Association (Ploc,
4350 Expression => Make_String_Literal (Ploc, Str)));
4351 end if;
4352
4353 -- Generate:
4354 -- pragma Check (<Nam>, <Expr>, <Str>);
4355
4356 Create_Append (Checks,
4357 Make_Pragma (Ploc,
4358 Pragma_Identifier =>
4359 Make_Identifier (Ploc, Name_Check),
4360 Pragma_Argument_Associations => Assoc));
4361 end if;
4362
4363 -- Output an info message when inheriting an invariant and the
4364 -- listing option is enabled.
4365
4366 if Inherit and Opt.List_Inherited_Aspects then
4367 Error_Msg_Sloc := Sloc (Prag);
4368 Error_Msg_N
4369 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
4370 end if;
4371
4372 -- Add the pragma to the list of processed pragmas
4373
4374 Append_New_Elmt (Prag, Pragmas_Seen);
4375 Produced_Check := True;
4376 end Add_Invariant;
4377
4378 ------------------
4379 -- Process_Type --
4380 ------------------
4381
4382 procedure Process_Type
4383 (T : Entity_Id;
4384 Stop_Item : Node_Id := Empty)
4385 is
4386 Rep_Item : Node_Id;
4387
4388 begin
4389 Rep_Item := First_Rep_Item (T);
4390 while Present (Rep_Item) loop
4391 if Nkind (Rep_Item) = N_Pragma
4392 and then Pragma_Name (Rep_Item) = Name_Invariant
4393 then
4394 -- Stop the traversal of the rep item chain once a specific
4395 -- item is encountered.
4396
4397 if Present (Stop_Item) and then Rep_Item = Stop_Item then
4398 exit;
4399
4400 -- Otherwise generate an invariant check
4401
4402 else
4403 Add_Invariant (Rep_Item);
4404 end if;
4405 end if;
4406
4407 Next_Rep_Item (Rep_Item);
4408 end loop;
4409 end Process_Type;
4410
4411 -- Start of processing for Add_Type_Invariants
4412
4413 begin
4414 -- Process the invariants of the partial view
4415
4416 if Present (Priv_Typ) then
4417 Process_Type (Priv_Typ);
4418 end if;
4419
4420 -- Process the invariants of the full view
4421
4422 if Present (Full_Typ) then
4423 Process_Type (Full_Typ, Stop_Item => Priv_Item);
4424
4425 -- Process the elements of an array type
4426
4427 if Is_Array_Type (Full_Typ) then
4428 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
4429
4430 -- Process the components of a record type
4431
4432 elsif Ekind (Full_Typ) = E_Record_Type then
4433 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
4434 end if;
4435 end if;
4436
4437 -- Process the components of a corresponding record type
4438
4439 if Present (CRec_Typ) then
4440 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Checks);
4441 end if;
4442 end Add_Type_Invariants;
4443
4444 -------------------
4445 -- Create_Append --
4446 -------------------
4447
4448 procedure Create_Append (L : in out List_Id; N : Node_Id) is
4449 begin
4450 if No (L) then
4451 L := New_List;
4452 end if;
4453
4454 Append_To (L, N);
4455 end Create_Append;
4456
4457 ------------------------------------
4458 -- Is_Untagged_Private_Derivation --
4459 ------------------------------------
4460
4461 function Is_Untagged_Private_Derivation
4462 (Priv_Typ : Entity_Id;
4463 Full_Typ : Entity_Id) return Boolean
4464 is
4465 begin
4466 return
4467 Present (Priv_Typ)
4468 and then Is_Untagged_Derivation (Priv_Typ)
4469 and then Is_Private_Type (Etype (Priv_Typ))
4470 and then Present (Full_Typ)
4471 and then Is_Itype (Full_Typ);
4472 end Is_Untagged_Private_Derivation;
4473
4474 -- Local variables
4475
4476 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4477
4478 Dummy : Entity_Id;
4479 Priv_Item : Node_Id;
4480 Proc_Body : Node_Id;
4481 Proc_Body_Id : Entity_Id;
4482 Proc_Decl : Node_Id;
4483 Proc_Id : Entity_Id;
4484 Stmts : List_Id := No_List;
4485
4486 CRec_Typ : Entity_Id;
4487 -- The corresponding record type of Full_Typ
4488
4489 Full_Proc : Entity_Id;
4490 -- The entity of the "full" invariant procedure
4491
4492 Full_Typ : Entity_Id;
4493 -- The full view of the working type
4494
4495 Freeze_Typ : Entity_Id;
4496 -- The freeze type whose freeze node carries the invariant procedure
4497 -- body. This is either the partial or the full view of the working
4498 -- type.
4499
4500 Obj_Id : Entity_Id;
4501 -- The _object formal parameter of the invariant procedure
4502
4503 Part_Proc : Entity_Id;
4504 -- The entity of the "partial" invariant procedure
4505
4506 Priv_Typ : Entity_Id;
4507 -- The partial view of the working type
4508
4509 Work_Typ : Entity_Id;
4510 -- The working type
4511
4512 -- Start of processing for Build_Invariant_Procedure_Body
4513
4514 begin
4515 Work_Typ := Typ;
4516
4517 -- The input type denotes the implementation base type of a constrained
4518 -- array type. Work with the first subtype as all invariant pragmas are
4519 -- on its rep item chain.
4520
4521 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
4522 Work_Typ := First_Subtype (Work_Typ);
4523
4524 -- The input type denotes the corresponding record type of a protected
4525 -- or task type. Work with the concurrent type because the corresponding
4526 -- record type may not be visible to clients of the type.
4527
4528 elsif Ekind (Work_Typ) = E_Record_Type
4529 and then Is_Concurrent_Record_Type (Work_Typ)
4530 then
4531 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
4532 end if;
4533
4534 -- The type must either have invariants of its own, inherit class-wide
4535 -- invariants from parent types or interfaces, or be an array or record
4536 -- type whose components have invariants.
4537
4538 pragma Assert (Has_Invariants (Work_Typ));
4539
4540 -- Nothing to do for interface types as their class-wide invariants are
4541 -- inherited by implementing types.
4542
4543 if Is_Interface (Work_Typ) then
4544 return;
4545 end if;
4546
4547 -- Obtain both views of the type
4548
4549 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
4550
4551 -- The caller requests a body for the partial invariant procedure
4552
4553 if Partial_Invariant then
4554 Full_Proc := Invariant_Procedure (Work_Typ);
4555 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
4556
4557 -- The "full" invariant procedure body was already created
4558
4559 if Present (Full_Proc)
4560 and then Present
4561 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
4562 then
4563 -- This scenario happens only when the type is an untagged
4564 -- derivation from a private parent and the underlying full
4565 -- view was processed before the partial view.
4566
4567 pragma Assert
4568 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
4569
4570 -- Nothing to do because the processing of the underlying full
4571 -- view already checked the invariants of the partial view.
4572
4573 return;
4574 end if;
4575
4576 -- Create a declaration for the "partial" invariant procedure if it
4577 -- is not available.
4578
4579 if No (Proc_Id) then
4580 Build_Invariant_Procedure_Declaration
4581 (Typ => Work_Typ,
4582 Partial_Invariant => True);
4583
4584 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
4585 end if;
4586
4587 -- The caller requests a body for the "full" invariant procedure
4588
4589 else
4590 Proc_Id := Invariant_Procedure (Work_Typ);
4591 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
4592
4593 -- Create a declaration for the "full" invariant procedure if it is
4594 -- not available.
4595
4596 if No (Proc_Id) then
4597 Build_Invariant_Procedure_Declaration (Work_Typ);
4598 Proc_Id := Invariant_Procedure (Work_Typ);
4599 end if;
4600 end if;
4601
4602 -- At this point there should be an invariant procedure declaration
4603
4604 pragma Assert (Present (Proc_Id));
4605 Proc_Decl := Unit_Declaration_Node (Proc_Id);
4606
4607 -- Nothing to do if the invariant procedure already has a body
4608
4609 if Present (Corresponding_Body (Proc_Decl)) then
4610 return;
4611 end if;
4612
4613 -- The working type may be subject to pragma Ghost. Set the mode now to
4614 -- ensure that the invariant procedure is properly marked as Ghost.
4615
4616 Set_Ghost_Mode_From_Entity (Work_Typ);
4617
4618 -- Emulate the environment of the invariant procedure by installing
4619 -- its scope and formal parameters. Note that this is not needed, but
4620 -- having the scope of the invariant procedure installed helps with
4621 -- the detection of invariant-related errors.
4622
4623 Push_Scope (Proc_Id);
4624 Install_Formals (Proc_Id);
4625
4626 Obj_Id := First_Formal (Proc_Id);
4627 pragma Assert (Present (Obj_Id));
4628
4629 -- The "partial" invariant procedure verifies the invariants of the
4630 -- partial view only.
4631
4632 if Partial_Invariant then
4633 pragma Assert (Present (Priv_Typ));
4634 Freeze_Typ := Priv_Typ;
4635
4636 Add_Type_Invariants
4637 (Priv_Typ => Priv_Typ,
4638 Full_Typ => Empty,
4639 CRec_Typ => Empty,
4640 Obj_Id => Obj_Id,
4641 Checks => Stmts);
4642
4643 -- Otherwise the "full" invariant procedure verifies the invariants of
4644 -- the full view, all array or record components, as well as class-wide
4645 -- invariants inherited from parent types or interfaces. In addition, it
4646 -- indirectly verifies the invariants of the partial view by calling the
4647 -- "partial" invariant procedure.
4648
4649 else
4650 pragma Assert (Present (Full_Typ));
4651 Freeze_Typ := Full_Typ;
4652
4653 -- Check the invariants of the partial view by calling the "partial"
4654 -- invariant procedure. Generate:
4655
4656 -- <Work_Typ>Partial_Invariant (_object);
4657
4658 if Present (Part_Proc) then
4659 Create_Append (Stmts,
4660 Make_Procedure_Call_Statement (Loc,
4661 Name => New_Occurrence_Of (Part_Proc, Loc),
4662 Parameter_Associations => New_List (
4663 New_Occurrence_Of (Obj_Id, Loc))));
4664
4665 Produced_Check := True;
4666 end if;
4667
4668 Priv_Item := Empty;
4669
4670 -- Derived subtypes do not have a partial view
4671
4672 if Present (Priv_Typ) then
4673
4674 -- The processing of the "full" invariant procedure intentionally
4675 -- skips the partial view because a) this may result in changes of
4676 -- visibility and b) lead to duplicate checks. However, when the
4677 -- full view is the underlying full view of an untagged derived
4678 -- type whose parent type is private, partial invariants appear on
4679 -- the rep item chain of the partial view only.
4680
4681 -- package Pack_1 is
4682 -- type Root ... is private;
4683 -- private
4684 -- <full view of Root>
4685 -- end Pack_1;
4686
4687 -- with Pack_1;
4688 -- package Pack_2 is
4689 -- type Child is new Pack_1.Root with Type_Invariant => ...;
4690 -- <underlying full view of Child>
4691 -- end Pack_2;
4692
4693 -- As a result, the processing of the full view must also consider
4694 -- all invariants of the partial view.
4695
4696 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
4697 null;
4698
4699 -- Otherwise the invariants of the partial view are ignored
4700
4701 else
4702 -- Note that the rep item chain is shared between the partial
4703 -- and full views of a type. To avoid processing the invariants
4704 -- of the partial view, signal the logic to stop when the first
4705 -- rep item of the partial view has been reached.
4706
4707 Priv_Item := First_Rep_Item (Priv_Typ);
4708
4709 -- Ignore the invariants of the partial view by eliminating the
4710 -- view.
4711
4712 Priv_Typ := Empty;
4713 end if;
4714 end if;
4715
4716 -- Process the invariants of the full view and in certain cases those
4717 -- of the partial view. This also handles any invariants on array or
4718 -- record components.
4719
4720 Add_Type_Invariants
4721 (Priv_Typ => Priv_Typ,
4722 Full_Typ => Full_Typ,
4723 CRec_Typ => CRec_Typ,
4724 Obj_Id => Obj_Id,
4725 Checks => Stmts,
4726 Priv_Item => Priv_Item);
4727
4728 -- Process the inherited class-wide invariants of all parent types.
4729 -- This also handles any invariants on record components.
4730
4731 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
4732
4733 -- Process the inherited class-wide invariants of all implemented
4734 -- interface types.
4735
4736 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
4737 end if;
4738
4739 End_Scope;
4740
4741 -- At this point there should be at least one invariant check. If this
4742 -- is not the case, then the invariant-related flags were not properly
4743 -- set, or there is a missing invariant procedure on one of the array
4744 -- or record components.
4745
4746 pragma Assert (Produced_Check);
4747
4748 -- Account for the case where assertions are disabled or all invariant
4749 -- checks are subject to Assertion_Policy Ignore. Produce a completing
4750 -- empty body.
4751
4752 if No (Stmts) then
4753 Stmts := New_List (Make_Null_Statement (Loc));
4754 end if;
4755
4756 -- Generate:
4757 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>) is
4758 -- begin
4759 -- <Stmts>
4760 -- end <Work_Typ>[Partial_]Invariant;
4761
4762 Proc_Body :=
4763 Make_Subprogram_Body (Loc,
4764 Specification =>
4765 Copy_Subprogram_Spec (Parent (Proc_Id)),
4766 Declarations => Empty_List,
4767 Handled_Statement_Sequence =>
4768 Make_Handled_Sequence_Of_Statements (Loc,
4769 Statements => Stmts));
4770 Proc_Body_Id := Defining_Entity (Proc_Body);
4771
4772 -- Perform minor decoration in case the body is not analyzed
4773
4774 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
4775 Set_Etype (Proc_Body_Id, Standard_Void_Type);
4776 Set_Scope (Proc_Body_Id, Current_Scope);
4777
4778 -- Link both spec and body to avoid generating duplicates
4779
4780 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
4781 Set_Corresponding_Spec (Proc_Body, Proc_Id);
4782
4783 -- The body should not be inserted into the tree when the context is
4784 -- ASIS, GNATprove or a generic unit because it is not part of the
4785 -- template. Note that the body must still be generated in order to
4786 -- resolve the invariants.
4787
4788 if ASIS_Mode or GNATprove_Mode or Inside_A_Generic then
4789 null;
4790
4791 -- Otherwise the body is part of the freezing actions of the type
4792
4793 else
4794 Append_Freeze_Action (Freeze_Typ, Proc_Body);
4795 end if;
4796
4797 Ghost_Mode := Save_Ghost_Mode;
4798 end Build_Invariant_Procedure_Body;
4799
4800 -------------------------------------------
4801 -- Build_Invariant_Procedure_Declaration --
4802 -------------------------------------------
4803
4804 procedure Build_Invariant_Procedure_Declaration
4805 (Typ : Entity_Id;
4806 Partial_Invariant : Boolean := False)
4807 is
4808 Loc : constant Source_Ptr := Sloc (Typ);
4809
4810 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
4811
4812 Proc_Decl : Node_Id;
4813 Proc_Id : Entity_Id;
4814 Proc_Nam : Name_Id;
4815 Typ_Decl : Node_Id;
4816
4817 CRec_Typ : Entity_Id;
4818 -- The corresponding record type of Full_Typ
4819
4820 Full_Base : Entity_Id;
4821 -- The base type of Full_Typ
4822
4823 Full_Typ : Entity_Id;
4824 -- The full view of working type
4825
4826 Obj_Id : Entity_Id;
4827 -- The _object formal parameter of the invariant procedure
4828
4829 Priv_Typ : Entity_Id;
4830 -- The partial view of working type
4831
4832 Work_Typ : Entity_Id;
4833 -- The working type
4834
4835 begin
4836 Work_Typ := Typ;
4837
4838 -- The input type denotes the implementation base type of a constrained
4839 -- array type. Work with the first subtype as all invariant pragmas are
4840 -- on its rep item chain.
4841
4842 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
4843 Work_Typ := First_Subtype (Work_Typ);
4844
4845 -- The input denotes the corresponding record type of a protected or a
4846 -- task type. Work with the concurrent type because the corresponding
4847 -- record type may not be visible to clients of the type.
4848
4849 elsif Ekind (Work_Typ) = E_Record_Type
4850 and then Is_Concurrent_Record_Type (Work_Typ)
4851 then
4852 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
4853 end if;
4854
4855 -- The type must either have invariants of its own, inherit class-wide
4856 -- invariants from parent or interface types, or be an array or record
4857 -- type whose components have invariants.
4858
4859 pragma Assert (Has_Invariants (Work_Typ));
4860
4861 -- Nothing to do for interface types as their class-wide invariants are
4862 -- inherited by implementing types.
4863
4864 if Is_Interface (Work_Typ) then
4865 return;
4866
4867 -- Nothing to do if the type already has a "partial" invariant procedure
4868
4869 elsif Partial_Invariant then
4870 if Present (Partial_Invariant_Procedure (Work_Typ)) then
4871 return;
4872 end if;
4873
4874 -- Nothing to do if the type already has a "full" invariant procedure
4875
4876 elsif Present (Invariant_Procedure (Work_Typ)) then
4877 return;
4878 end if;
4879
4880 -- The working type may be subject to pragma Ghost. Set the mode now to
4881 -- ensure that the invariant procedure is properly marked as Ghost.
4882
4883 Set_Ghost_Mode_From_Entity (Work_Typ);
4884
4885 -- The caller requests the declaration of the "partial" invariant
4886 -- procedure.
4887
4888 if Partial_Invariant then
4889 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
4890
4891 -- Otherwise the caller requests the declaration of the "full" invariant
4892 -- procedure.
4893
4894 else
4895 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
4896 end if;
4897
4898 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
4899
4900 -- Perform minor decoration in case the declaration is not analyzed
4901
4902 Set_Ekind (Proc_Id, E_Procedure);
4903 Set_Etype (Proc_Id, Standard_Void_Type);
4904 Set_Scope (Proc_Id, Current_Scope);
4905
4906 if Partial_Invariant then
4907 Set_Is_Partial_Invariant_Procedure (Proc_Id);
4908 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
4909 else
4910 Set_Is_Invariant_Procedure (Proc_Id);
4911 Set_Invariant_Procedure (Work_Typ, Proc_Id);
4912 end if;
4913
4914 -- The invariant procedure requires debug info when the invariants are
4915 -- subject to Source Coverage Obligations.
4916
4917 if Opt.Generate_SCO then
4918 Set_Needs_Debug_Info (Proc_Id);
4919 end if;
4920
4921 -- Mark the invariant procedure explicitly as Ghost because it does not
4922 -- come from source.
4923
4924 if Ghost_Mode > None then
4925 Set_Is_Ghost_Entity (Proc_Id);
4926 end if;
4927
4928 -- Obtain all views of the input type
4929
4930 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
4931
4932 -- Associate the invariant procedure with all views
4933
4934 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
4935 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
4936 Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ);
4937 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
4938
4939 -- The declaration of the invariant procedure is inserted after the
4940 -- declaration of the partial view as this allows for proper external
4941 -- visibility.
4942
4943 if Present (Priv_Typ) then
4944 Typ_Decl := Declaration_Node (Priv_Typ);
4945
4946 -- Derived types with the full view as parent do not have a partial
4947 -- view. Insert the invariant procedure after the derived type.
4948
4949 else
4950 Typ_Decl := Declaration_Node (Full_Typ);
4951 end if;
4952
4953 -- The type should have a declarative node
4954
4955 pragma Assert (Present (Typ_Decl));
4956
4957 -- Create the formal parameter which emulates the variable-like behavior
4958 -- of the current type instance.
4959
4960 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
4961
4962 -- Perform minor decoration in case the declaration is not analyzed
4963
4964 Set_Ekind (Obj_Id, E_In_Parameter);
4965 Set_Etype (Obj_Id, Work_Typ);
4966 Set_Scope (Obj_Id, Proc_Id);
4967
4968 Set_First_Entity (Proc_Id, Obj_Id);
4969
4970 -- Generate:
4971 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>);
4972
4973 Proc_Decl :=
4974 Make_Subprogram_Declaration (Loc,
4975 Specification =>
4976 Make_Procedure_Specification (Loc,
4977 Defining_Unit_Name => Proc_Id,
4978 Parameter_Specifications => New_List (
4979 Make_Parameter_Specification (Loc,
4980 Defining_Identifier => Obj_Id,
4981 Parameter_Type =>
4982 New_Occurrence_Of (Work_Typ, Loc)))));
4983
4984 -- The declaration should not be inserted into the tree when the context
4985 -- is ASIS, GNATprove or a generic unit because it is not part of the
4986 -- template.
4987
4988 if ASIS_Mode or GNATprove_Mode or Inside_A_Generic then
4989 null;
4990
4991 -- Otherwise insert the declaration
4992
4993 else
4994 pragma Assert (Present (Typ_Decl));
4995 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
4996 end if;
4997
4998 Ghost_Mode := Save_Ghost_Mode;
4999 end Build_Invariant_Procedure_Declaration;
5000
5001 ---------------------
5002 -- Build_Late_Proc --
5003 ---------------------
5004
5005 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
5006 begin
5007 for Final_Prim in Name_Of'Range loop
5008 if Name_Of (Final_Prim) = Nam then
5009 Set_TSS (Typ,
5010 Make_Deep_Proc
5011 (Prim => Final_Prim,
5012 Typ => Typ,
5013 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
5014 end if;
5015 end loop;
5016 end Build_Late_Proc;
5017
5018 -------------------------------
5019 -- Build_Object_Declarations --
5020 -------------------------------
5021
5022 procedure Build_Object_Declarations
5023 (Data : out Finalization_Exception_Data;
5024 Decls : List_Id;
5025 Loc : Source_Ptr;
5026 For_Package : Boolean := False)
5027 is
5028 Decl : Node_Id;
5029
5030 Dummy : Entity_Id;
5031 -- This variable captures an unused dummy internal entity, see the
5032 -- comment associated with its use.
5033
5034 begin
5035 pragma Assert (Decls /= No_List);
5036
5037 -- Always set the proper location as it may be needed even when
5038 -- exception propagation is forbidden.
5039
5040 Data.Loc := Loc;
5041
5042 if Restriction_Active (No_Exception_Propagation) then
5043 Data.Abort_Id := Empty;
5044 Data.E_Id := Empty;
5045 Data.Raised_Id := Empty;
5046 return;
5047 end if;
5048
5049 Data.Raised_Id := Make_Temporary (Loc, 'R');
5050
5051 -- In certain scenarios, finalization can be triggered by an abort. If
5052 -- the finalization itself fails and raises an exception, the resulting
5053 -- Program_Error must be supressed and replaced by an abort signal. In
5054 -- order to detect this scenario, save the state of entry into the
5055 -- finalization code.
5056
5057 -- This is not needed for library-level finalizers as they are called by
5058 -- the environment task and cannot be aborted.
5059
5060 if not For_Package then
5061 if Abort_Allowed then
5062 Data.Abort_Id := Make_Temporary (Loc, 'A');
5063
5064 -- Generate:
5065 -- Abort_Id : constant Boolean := <A_Expr>;
5066
5067 Append_To (Decls,
5068 Make_Object_Declaration (Loc,
5069 Defining_Identifier => Data.Abort_Id,
5070 Constant_Present => True,
5071 Object_Definition =>
5072 New_Occurrence_Of (Standard_Boolean, Loc),
5073 Expression =>
5074 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
5075
5076 -- Abort is not required
5077
5078 else
5079 -- Generate a dummy entity to ensure that the internal symbols are
5080 -- in sync when a unit is compiled with and without aborts.
5081
5082 Dummy := Make_Temporary (Loc, 'A');
5083 Data.Abort_Id := Empty;
5084 end if;
5085
5086 -- Library-level finalizers
5087
5088 else
5089 Data.Abort_Id := Empty;
5090 end if;
5091
5092 if Exception_Extra_Info then
5093 Data.E_Id := Make_Temporary (Loc, 'E');
5094
5095 -- Generate:
5096 -- E_Id : Exception_Occurrence;
5097
5098 Decl :=
5099 Make_Object_Declaration (Loc,
5100 Defining_Identifier => Data.E_Id,
5101 Object_Definition =>
5102 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
5103 Set_No_Initialization (Decl);
5104
5105 Append_To (Decls, Decl);
5106
5107 else
5108 Data.E_Id := Empty;
5109 end if;
5110
5111 -- Generate:
5112 -- Raised_Id : Boolean := False;
5113
5114 Append_To (Decls,
5115 Make_Object_Declaration (Loc,
5116 Defining_Identifier => Data.Raised_Id,
5117 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
5118 Expression => New_Occurrence_Of (Standard_False, Loc)));
5119 end Build_Object_Declarations;
5120
5121 ---------------------------
5122 -- Build_Raise_Statement --
5123 ---------------------------
5124
5125 function Build_Raise_Statement
5126 (Data : Finalization_Exception_Data) return Node_Id
5127 is
5128 Stmt : Node_Id;
5129 Expr : Node_Id;
5130
5131 begin
5132 -- Standard run-time use the specialized routine
5133 -- Raise_From_Controlled_Operation.
5134
5135 if Exception_Extra_Info
5136 and then RTE_Available (RE_Raise_From_Controlled_Operation)
5137 then
5138 Stmt :=
5139 Make_Procedure_Call_Statement (Data.Loc,
5140 Name =>
5141 New_Occurrence_Of
5142 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
5143 Parameter_Associations =>
5144 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
5145
5146 -- Restricted run-time: exception messages are not supported and hence
5147 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
5148 -- instead.
5149
5150 else
5151 Stmt :=
5152 Make_Raise_Program_Error (Data.Loc,
5153 Reason => PE_Finalize_Raised_Exception);
5154 end if;
5155
5156 -- Generate:
5157
5158 -- Raised_Id and then not Abort_Id
5159 -- <or>
5160 -- Raised_Id
5161
5162 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
5163
5164 if Present (Data.Abort_Id) then
5165 Expr := Make_And_Then (Data.Loc,
5166 Left_Opnd => Expr,
5167 Right_Opnd =>
5168 Make_Op_Not (Data.Loc,
5169 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
5170 end if;
5171
5172 -- Generate:
5173
5174 -- if Raised_Id and then not Abort_Id then
5175 -- Raise_From_Controlled_Operation (E_Id);
5176 -- <or>
5177 -- raise Program_Error; -- restricted runtime
5178 -- end if;
5179
5180 return
5181 Make_If_Statement (Data.Loc,
5182 Condition => Expr,
5183 Then_Statements => New_List (Stmt));
5184 end Build_Raise_Statement;
5185
5186 -----------------------------
5187 -- Build_Record_Deep_Procs --
5188 -----------------------------
5189
5190 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
5191 begin
5192 Set_TSS (Typ,
5193 Make_Deep_Proc
5194 (Prim => Initialize_Case,
5195 Typ => Typ,
5196 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
5197
5198 if not Is_Limited_View (Typ) then
5199 Set_TSS (Typ,
5200 Make_Deep_Proc
5201 (Prim => Adjust_Case,
5202 Typ => Typ,
5203 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
5204 end if;
5205
5206 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
5207 -- suppressed since these routine will not be used.
5208
5209 if not Restriction_Active (No_Finalization) then
5210 Set_TSS (Typ,
5211 Make_Deep_Proc
5212 (Prim => Finalize_Case,
5213 Typ => Typ,
5214 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
5215
5216 -- Create TSS primitive Finalize_Address
5217
5218 Set_TSS (Typ,
5219 Make_Deep_Proc
5220 (Prim => Address_Case,
5221 Typ => Typ,
5222 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
5223 end if;
5224 end Build_Record_Deep_Procs;
5225
5226 -------------------
5227 -- Cleanup_Array --
5228 -------------------
5229
5230 function Cleanup_Array
5231 (N : Node_Id;
5232 Obj : Node_Id;
5233 Typ : Entity_Id) return List_Id
5234 is
5235 Loc : constant Source_Ptr := Sloc (N);
5236 Index_List : constant List_Id := New_List;
5237
5238 function Free_Component return List_Id;
5239 -- Generate the code to finalize the task or protected subcomponents
5240 -- of a single component of the array.
5241
5242 function Free_One_Dimension (Dim : Int) return List_Id;
5243 -- Generate a loop over one dimension of the array
5244
5245 --------------------
5246 -- Free_Component --
5247 --------------------
5248
5249 function Free_Component return List_Id is
5250 Stmts : List_Id := New_List;
5251 Tsk : Node_Id;
5252 C_Typ : constant Entity_Id := Component_Type (Typ);
5253
5254 begin
5255 -- Component type is known to contain tasks or protected objects
5256
5257 Tsk :=
5258 Make_Indexed_Component (Loc,
5259 Prefix => Duplicate_Subexpr_No_Checks (Obj),
5260 Expressions => Index_List);
5261
5262 Set_Etype (Tsk, C_Typ);
5263
5264 if Is_Task_Type (C_Typ) then
5265 Append_To (Stmts, Cleanup_Task (N, Tsk));
5266
5267 elsif Is_Simple_Protected_Type (C_Typ) then
5268 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
5269
5270 elsif Is_Record_Type (C_Typ) then
5271 Stmts := Cleanup_Record (N, Tsk, C_Typ);
5272
5273 elsif Is_Array_Type (C_Typ) then
5274 Stmts := Cleanup_Array (N, Tsk, C_Typ);
5275 end if;
5276
5277 return Stmts;
5278 end Free_Component;
5279
5280 ------------------------
5281 -- Free_One_Dimension --
5282 ------------------------
5283
5284 function Free_One_Dimension (Dim : Int) return List_Id is
5285 Index : Entity_Id;
5286
5287 begin
5288 if Dim > Number_Dimensions (Typ) then
5289 return Free_Component;
5290
5291 -- Here we generate the required loop
5292
5293 else
5294 Index := Make_Temporary (Loc, 'J');
5295 Append (New_Occurrence_Of (Index, Loc), Index_List);
5296
5297 return New_List (
5298 Make_Implicit_Loop_Statement (N,
5299 Identifier => Empty,
5300 Iteration_Scheme =>
5301 Make_Iteration_Scheme (Loc,
5302 Loop_Parameter_Specification =>
5303 Make_Loop_Parameter_Specification (Loc,
5304 Defining_Identifier => Index,
5305 Discrete_Subtype_Definition =>
5306 Make_Attribute_Reference (Loc,
5307 Prefix => Duplicate_Subexpr (Obj),
5308 Attribute_Name => Name_Range,
5309 Expressions => New_List (
5310 Make_Integer_Literal (Loc, Dim))))),
5311 Statements => Free_One_Dimension (Dim + 1)));
5312 end if;
5313 end Free_One_Dimension;
5314
5315 -- Start of processing for Cleanup_Array
5316
5317 begin
5318 return Free_One_Dimension (1);
5319 end Cleanup_Array;
5320
5321 --------------------
5322 -- Cleanup_Record --
5323 --------------------
5324
5325 function Cleanup_Record
5326 (N : Node_Id;
5327 Obj : Node_Id;
5328 Typ : Entity_Id) return List_Id
5329 is
5330 Loc : constant Source_Ptr := Sloc (N);
5331 Tsk : Node_Id;
5332 Comp : Entity_Id;
5333 Stmts : constant List_Id := New_List;
5334 U_Typ : constant Entity_Id := Underlying_Type (Typ);
5335
5336 begin
5337 if Has_Discriminants (U_Typ)
5338 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
5339 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
5340 and then
5341 Present
5342 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
5343 then
5344 -- For now, do not attempt to free a component that may appear in a
5345 -- variant, and instead issue a warning. Doing this "properly" would
5346 -- require building a case statement and would be quite a mess. Note
5347 -- that the RM only requires that free "work" for the case of a task
5348 -- access value, so already we go way beyond this in that we deal
5349 -- with the array case and non-discriminated record cases.
5350
5351 Error_Msg_N
5352 ("task/protected object in variant record will not be freed??", N);
5353 return New_List (Make_Null_Statement (Loc));
5354 end if;
5355
5356 Comp := First_Component (Typ);
5357 while Present (Comp) loop
5358 if Has_Task (Etype (Comp))
5359 or else Has_Simple_Protected_Object (Etype (Comp))
5360 then
5361 Tsk :=
5362 Make_Selected_Component (Loc,
5363 Prefix => Duplicate_Subexpr_No_Checks (Obj),
5364 Selector_Name => New_Occurrence_Of (Comp, Loc));
5365 Set_Etype (Tsk, Etype (Comp));
5366
5367 if Is_Task_Type (Etype (Comp)) then
5368 Append_To (Stmts, Cleanup_Task (N, Tsk));
5369
5370 elsif Is_Simple_Protected_Type (Etype (Comp)) then
5371 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
5372
5373 elsif Is_Record_Type (Etype (Comp)) then
5374
5375 -- Recurse, by generating the prefix of the argument to
5376 -- the eventual cleanup call.
5377
5378 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
5379
5380 elsif Is_Array_Type (Etype (Comp)) then
5381 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
5382 end if;
5383 end if;
5384
5385 Next_Component (Comp);
5386 end loop;
5387
5388 return Stmts;
5389 end Cleanup_Record;
5390
5391 ------------------------------
5392 -- Cleanup_Protected_Object --
5393 ------------------------------
5394
5395 function Cleanup_Protected_Object
5396 (N : Node_Id;
5397 Ref : Node_Id) return Node_Id
5398 is
5399 Loc : constant Source_Ptr := Sloc (N);
5400
5401 begin
5402 -- For restricted run-time libraries (Ravenscar), tasks are
5403 -- non-terminating, and protected objects can only appear at library
5404 -- level, so we do not want finalization of protected objects.
5405
5406 if Restricted_Profile then
5407 return Empty;
5408
5409 else
5410 return
5411 Make_Procedure_Call_Statement (Loc,
5412 Name =>
5413 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
5414 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
5415 end if;
5416 end Cleanup_Protected_Object;
5417
5418 ------------------
5419 -- Cleanup_Task --
5420 ------------------
5421
5422 function Cleanup_Task
5423 (N : Node_Id;
5424 Ref : Node_Id) return Node_Id
5425 is
5426 Loc : constant Source_Ptr := Sloc (N);
5427
5428 begin
5429 -- For restricted run-time libraries (Ravenscar), tasks are
5430 -- non-terminating and they can only appear at library level, so we do
5431 -- not want finalization of task objects.
5432
5433 if Restricted_Profile then
5434 return Empty;
5435
5436 else
5437 return
5438 Make_Procedure_Call_Statement (Loc,
5439 Name =>
5440 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
5441 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
5442 end if;
5443 end Cleanup_Task;
5444
5445 ------------------------------
5446 -- Check_Visibly_Controlled --
5447 ------------------------------
5448
5449 procedure Check_Visibly_Controlled
5450 (Prim : Final_Primitives;
5451 Typ : Entity_Id;
5452 E : in out Entity_Id;
5453 Cref : in out Node_Id)
5454 is
5455 Parent_Type : Entity_Id;
5456 Op : Entity_Id;
5457
5458 begin
5459 if Is_Derived_Type (Typ)
5460 and then Comes_From_Source (E)
5461 and then not Present (Overridden_Operation (E))
5462 then
5463 -- We know that the explicit operation on the type does not override
5464 -- the inherited operation of the parent, and that the derivation
5465 -- is from a private type that is not visibly controlled.
5466
5467 Parent_Type := Etype (Typ);
5468 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
5469
5470 if Present (Op) then
5471 E := Op;
5472
5473 -- Wrap the object to be initialized into the proper
5474 -- unchecked conversion, to be compatible with the operation
5475 -- to be called.
5476
5477 if Nkind (Cref) = N_Unchecked_Type_Conversion then
5478 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
5479 else
5480 Cref := Unchecked_Convert_To (Parent_Type, Cref);
5481 end if;
5482 end if;
5483 end if;
5484 end Check_Visibly_Controlled;
5485
5486 ------------------
5487 -- Convert_View --
5488 ------------------
5489
5490 function Convert_View
5491 (Proc : Entity_Id;
5492 Arg : Node_Id;
5493 Ind : Pos := 1) return Node_Id
5494 is
5495 Fent : Entity_Id := First_Entity (Proc);
5496 Ftyp : Entity_Id;
5497 Atyp : Entity_Id;
5498
5499 begin
5500 for J in 2 .. Ind loop
5501 Next_Entity (Fent);
5502 end loop;
5503
5504 Ftyp := Etype (Fent);
5505
5506 if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
5507 Atyp := Entity (Subtype_Mark (Arg));
5508 else
5509 Atyp := Etype (Arg);
5510 end if;
5511
5512 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
5513 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
5514
5515 elsif Ftyp /= Atyp
5516 and then Present (Atyp)
5517 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
5518 and then Base_Type (Underlying_Type (Atyp)) =
5519 Base_Type (Underlying_Type (Ftyp))
5520 then
5521 return Unchecked_Convert_To (Ftyp, Arg);
5522
5523 -- If the argument is already a conversion, as generated by
5524 -- Make_Init_Call, set the target type to the type of the formal
5525 -- directly, to avoid spurious typing problems.
5526
5527 elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
5528 and then not Is_Class_Wide_Type (Atyp)
5529 then
5530 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
5531 Set_Etype (Arg, Ftyp);
5532 return Arg;
5533
5534 -- Otherwise, introduce a conversion when the designated object
5535 -- has a type derived from the formal of the controlled routine.
5536
5537 elsif Is_Private_Type (Ftyp)
5538 and then Present (Atyp)
5539 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
5540 then
5541 return Unchecked_Convert_To (Ftyp, Arg);
5542
5543 else
5544 return Arg;
5545 end if;
5546 end Convert_View;
5547
5548 -------------------------------
5549 -- CW_Or_Has_Controlled_Part --
5550 -------------------------------
5551
5552 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
5553 begin
5554 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
5555 end CW_Or_Has_Controlled_Part;
5556
5557 ------------------------
5558 -- Enclosing_Function --
5559 ------------------------
5560
5561 function Enclosing_Function (E : Entity_Id) return Entity_Id is
5562 Func_Id : Entity_Id;
5563
5564 begin
5565 Func_Id := E;
5566 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
5567 if Ekind (Func_Id) = E_Function then
5568 return Func_Id;
5569 end if;
5570
5571 Func_Id := Scope (Func_Id);
5572 end loop;
5573
5574 return Empty;
5575 end Enclosing_Function;
5576
5577 -------------------------------
5578 -- Establish_Transient_Scope --
5579 -------------------------------
5580
5581 -- This procedure is called each time a transient block has to be inserted
5582 -- that is to say for each call to a function with unconstrained or tagged
5583 -- result. It creates a new scope on the stack scope in order to enclose
5584 -- all transient variables generated.
5585
5586 procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
5587 Loc : constant Source_Ptr := Sloc (N);
5588 Iter_Loop : Entity_Id;
5589 Wrap_Node : Node_Id;
5590
5591 begin
5592 -- Do not create a transient scope if we are already inside one
5593
5594 for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
5595 if Scope_Stack.Table (S).Is_Transient then
5596 if Sec_Stack then
5597 Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
5598 end if;
5599
5600 return;
5601
5602 -- If we encounter Standard there are no enclosing transient scopes
5603
5604 elsif Scope_Stack.Table (S).Entity = Standard_Standard then
5605 exit;
5606 end if;
5607 end loop;
5608
5609 Wrap_Node := Find_Node_To_Be_Wrapped (N);
5610
5611 -- The context does not contain a node that requires a transient scope,
5612 -- nothing to do.
5613
5614 if No (Wrap_Node) then
5615 null;
5616
5617 -- If the node to wrap is an iteration_scheme, the expression is one of
5618 -- the bounds, and the expansion will make an explicit declaration for
5619 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
5620 -- transformations here. Same for an Ada 2012 iterator specification,
5621 -- where a block is created for the expression that build the container.
5622
5623 elsif Nkind_In (Wrap_Node, N_Iteration_Scheme,
5624 N_Iterator_Specification)
5625 then
5626 null;
5627
5628 -- In formal verification mode, if the node to wrap is a pragma check,
5629 -- this node and enclosed expression are not expanded, so do not apply
5630 -- any transformations here.
5631
5632 elsif GNATprove_Mode
5633 and then Nkind (Wrap_Node) = N_Pragma
5634 and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
5635 then
5636 null;
5637
5638 -- Create a block entity to act as a transient scope. Note that when the
5639 -- node to be wrapped is an expression or a statement, a real physical
5640 -- block is constructed (see routines Wrap_Transient_Expression and
5641 -- Wrap_Transient_Statement) and inserted into the tree.
5642
5643 else
5644 Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
5645 Set_Scope_Is_Transient;
5646
5647 -- The transient scope must also take care of the secondary stack
5648 -- management.
5649
5650 if Sec_Stack then
5651 Set_Uses_Sec_Stack (Current_Scope);
5652 Check_Restriction (No_Secondary_Stack, N);
5653
5654 -- The expansion of iterator loops generates references to objects
5655 -- in order to extract elements from a container:
5656
5657 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
5658 -- Obj : <object type> renames Ref.all.Element.all;
5659
5660 -- These references are controlled and returned on the secondary
5661 -- stack. A new reference is created at each iteration of the loop
5662 -- and as a result it must be finalized and the space occupied by
5663 -- it on the secondary stack reclaimed at the end of the current
5664 -- iteration.
5665
5666 -- When the context that requires a transient scope is a call to
5667 -- routine Reference, the node to be wrapped is the source object:
5668
5669 -- for Obj of Container loop
5670
5671 -- Routine Wrap_Transient_Declaration however does not generate a
5672 -- physical block as wrapping a declaration will kill it too ealy.
5673 -- To handle this peculiar case, mark the related iterator loop as
5674 -- requiring the secondary stack. This signals the finalization
5675 -- machinery to manage the secondary stack (see routine
5676 -- Process_Statements_For_Controlled_Objects).
5677
5678 Iter_Loop := Find_Enclosing_Iterator_Loop (Current_Scope);
5679
5680 if Present (Iter_Loop) then
5681 Set_Uses_Sec_Stack (Iter_Loop);
5682 end if;
5683 end if;
5684
5685 Set_Etype (Current_Scope, Standard_Void_Type);
5686 Set_Node_To_Be_Wrapped (Wrap_Node);
5687
5688 if Debug_Flag_W then
5689 Write_Str (" <Transient>");
5690 Write_Eol;
5691 end if;
5692 end if;
5693 end Establish_Transient_Scope;
5694
5695 ----------------------------
5696 -- Expand_Cleanup_Actions --
5697 ----------------------------
5698
5699 procedure Expand_Cleanup_Actions (N : Node_Id) is
5700 Scop : constant Entity_Id := Current_Scope;
5701
5702 Is_Asynchronous_Call : constant Boolean :=
5703 Nkind (N) = N_Block_Statement
5704 and then Is_Asynchronous_Call_Block (N);
5705 Is_Master : constant Boolean :=
5706 Nkind (N) /= N_Entry_Body
5707 and then Is_Task_Master (N);
5708 Is_Protected_Body : constant Boolean :=
5709 Nkind (N) = N_Subprogram_Body
5710 and then Is_Protected_Subprogram_Body (N);
5711 Is_Task_Allocation : constant Boolean :=
5712 Nkind (N) = N_Block_Statement
5713 and then Is_Task_Allocation_Block (N);
5714 Is_Task_Body : constant Boolean :=
5715 Nkind (Original_Node (N)) = N_Task_Body;
5716 Needs_Sec_Stack_Mark : constant Boolean :=
5717 Uses_Sec_Stack (Scop)
5718 and then
5719 not Sec_Stack_Needed_For_Return (Scop);
5720 Needs_Custom_Cleanup : constant Boolean :=
5721 Nkind (N) = N_Block_Statement
5722 and then Present (Cleanup_Actions (N));
5723
5724 Actions_Required : constant Boolean :=
5725 Requires_Cleanup_Actions (N, True)
5726 or else Is_Asynchronous_Call
5727 or else Is_Master
5728 or else Is_Protected_Body
5729 or else Is_Task_Allocation
5730 or else Is_Task_Body
5731 or else Needs_Sec_Stack_Mark
5732 or else Needs_Custom_Cleanup;
5733
5734 HSS : Node_Id := Handled_Statement_Sequence (N);
5735 Loc : Source_Ptr;
5736 Cln : List_Id;
5737
5738 procedure Wrap_HSS_In_Block;
5739 -- Move HSS inside a new block along with the original exception
5740 -- handlers. Make the newly generated block the sole statement of HSS.
5741
5742 -----------------------
5743 -- Wrap_HSS_In_Block --
5744 -----------------------
5745
5746 procedure Wrap_HSS_In_Block is
5747 Block : Node_Id;
5748 Block_Id : Entity_Id;
5749 End_Lab : Node_Id;
5750
5751 begin
5752 -- Preserve end label to provide proper cross-reference information
5753
5754 End_Lab := End_Label (HSS);
5755 Block :=
5756 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
5757
5758 Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
5759 Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
5760 Set_Etype (Block_Id, Standard_Void_Type);
5761 Set_Block_Node (Block_Id, Identifier (Block));
5762
5763 -- Signal the finalization machinery that this particular block
5764 -- contains the original context.
5765
5766 Set_Is_Finalization_Wrapper (Block);
5767
5768 Set_Handled_Statement_Sequence (N,
5769 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
5770 HSS := Handled_Statement_Sequence (N);
5771
5772 Set_First_Real_Statement (HSS, Block);
5773 Set_End_Label (HSS, End_Lab);
5774
5775 -- Comment needed here, see RH for 1.306 ???
5776
5777 if Nkind (N) = N_Subprogram_Body then
5778 Set_Has_Nested_Block_With_Handler (Scop);
5779 end if;
5780 end Wrap_HSS_In_Block;
5781
5782 -- Start of processing for Expand_Cleanup_Actions
5783
5784 begin
5785 -- The current construct does not need any form of servicing
5786
5787 if not Actions_Required then
5788 return;
5789
5790 -- If the current node is a rewritten task body and the descriptors have
5791 -- not been delayed (due to some nested instantiations), do not generate
5792 -- redundant cleanup actions.
5793
5794 elsif Is_Task_Body
5795 and then Nkind (N) = N_Subprogram_Body
5796 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
5797 then
5798 return;
5799 end if;
5800
5801 if Needs_Custom_Cleanup then
5802 Cln := Cleanup_Actions (N);
5803 else
5804 Cln := No_List;
5805 end if;
5806
5807 declare
5808 Decls : List_Id := Declarations (N);
5809 Fin_Id : Entity_Id;
5810 Mark : Entity_Id := Empty;
5811 New_Decls : List_Id;
5812 Old_Poll : Boolean;
5813
5814 begin
5815 -- If we are generating expanded code for debugging purposes, use the
5816 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5817 -- be updated subsequently to reference the proper line in .dg files.
5818 -- If we are not debugging generated code, use No_Location instead,
5819 -- so that no debug information is generated for the cleanup code.
5820 -- This makes the behavior of the NEXT command in GDB monotonic, and
5821 -- makes the placement of breakpoints more accurate.
5822
5823 if Debug_Generated_Code then
5824 Loc := Sloc (Scop);
5825 else
5826 Loc := No_Location;
5827 end if;
5828
5829 -- Set polling off. The finalization and cleanup code is executed
5830 -- with aborts deferred.
5831
5832 Old_Poll := Polling_Required;
5833 Polling_Required := False;
5834
5835 -- A task activation call has already been built for a task
5836 -- allocation block.
5837
5838 if not Is_Task_Allocation then
5839 Build_Task_Activation_Call (N);
5840 end if;
5841
5842 if Is_Master then
5843 Establish_Task_Master (N);
5844 end if;
5845
5846 New_Decls := New_List;
5847
5848 -- If secondary stack is in use, generate:
5849 --
5850 -- Mnn : constant Mark_Id := SS_Mark;
5851
5852 if Needs_Sec_Stack_Mark then
5853 Mark := Make_Temporary (Loc, 'M');
5854
5855 Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
5856 Set_Uses_Sec_Stack (Scop, False);
5857 end if;
5858
5859 -- If exception handlers are present, wrap the sequence of statements
5860 -- in a block since it is not possible to have exception handlers and
5861 -- an At_End handler in the same construct.
5862
5863 if Present (Exception_Handlers (HSS)) then
5864 Wrap_HSS_In_Block;
5865
5866 -- Ensure that the First_Real_Statement field is set
5867
5868 elsif No (First_Real_Statement (HSS)) then
5869 Set_First_Real_Statement (HSS, First (Statements (HSS)));
5870 end if;
5871
5872 -- Do not move the Activation_Chain declaration in the context of
5873 -- task allocation blocks. Task allocation blocks use _chain in their
5874 -- cleanup handlers and gigi complains if it is declared in the
5875 -- sequence of statements of the scope that declares the handler.
5876
5877 if Is_Task_Allocation then
5878 declare
5879 Chain : constant Entity_Id := Activation_Chain_Entity (N);
5880 Decl : Node_Id;
5881
5882 begin
5883 Decl := First (Decls);
5884 while Nkind (Decl) /= N_Object_Declaration
5885 or else Defining_Identifier (Decl) /= Chain
5886 loop
5887 Next (Decl);
5888
5889 -- A task allocation block should always include a _chain
5890 -- declaration.
5891
5892 pragma Assert (Present (Decl));
5893 end loop;
5894
5895 Remove (Decl);
5896 Prepend_To (New_Decls, Decl);
5897 end;
5898 end if;
5899
5900 -- Ensure the presence of a declaration list in order to successfully
5901 -- append all original statements to it.
5902
5903 if No (Decls) then
5904 Set_Declarations (N, New_List);
5905 Decls := Declarations (N);
5906 end if;
5907
5908 -- Move the declarations into the sequence of statements in order to
5909 -- have them protected by the At_End handler. It may seem weird to
5910 -- put declarations in the sequence of statement but in fact nothing
5911 -- forbids that at the tree level.
5912
5913 Append_List_To (Decls, Statements (HSS));
5914 Set_Statements (HSS, Decls);
5915
5916 -- Reset the Sloc of the handled statement sequence to properly
5917 -- reflect the new initial "statement" in the sequence.
5918
5919 Set_Sloc (HSS, Sloc (First (Decls)));
5920
5921 -- The declarations of finalizer spec and auxiliary variables replace
5922 -- the old declarations that have been moved inward.
5923
5924 Set_Declarations (N, New_Decls);
5925 Analyze_Declarations (New_Decls);
5926
5927 -- Generate finalization calls for all controlled objects appearing
5928 -- in the statements of N. Add context specific cleanup for various
5929 -- constructs.
5930
5931 Build_Finalizer
5932 (N => N,
5933 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
5934 Mark_Id => Mark,
5935 Top_Decls => New_Decls,
5936 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
5937 or else Is_Master,
5938 Fin_Id => Fin_Id);
5939
5940 if Present (Fin_Id) then
5941 Build_Finalizer_Call (N, Fin_Id);
5942 end if;
5943
5944 -- Restore saved polling mode
5945
5946 Polling_Required := Old_Poll;
5947 end;
5948 end Expand_Cleanup_Actions;
5949
5950 ---------------------------
5951 -- Expand_N_Package_Body --
5952 ---------------------------
5953
5954 -- Add call to Activate_Tasks if body is an activator (actual processing
5955 -- is in chapter 9).
5956
5957 -- Generate subprogram descriptor for elaboration routine
5958
5959 -- Encode entity names in package body
5960
5961 procedure Expand_N_Package_Body (N : Node_Id) is
5962 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
5963 Fin_Id : Entity_Id;
5964
5965 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
5966
5967 begin
5968 -- The package body is Ghost when the corresponding spec is Ghost. Set
5969 -- the mode now to ensure that any nodes generated during expansion are
5970 -- properly marked as Ghost.
5971
5972 Set_Ghost_Mode (N, Spec_Id);
5973
5974 -- This is done only for non-generic packages
5975
5976 if Ekind (Spec_Id) = E_Package then
5977 Push_Scope (Corresponding_Spec (N));
5978
5979 -- Build dispatch tables of library level tagged types
5980
5981 if Tagged_Type_Expansion
5982 and then Is_Library_Level_Entity (Spec_Id)
5983 then
5984 Build_Static_Dispatch_Tables (N);
5985 end if;
5986
5987 Build_Task_Activation_Call (N);
5988
5989 -- When the package is subject to pragma Initial_Condition, the
5990 -- assertion expression must be verified at the end of the body
5991 -- statements.
5992
5993 if Present (Get_Pragma (Spec_Id, Pragma_Initial_Condition)) then
5994 Expand_Pragma_Initial_Condition (N);
5995 end if;
5996
5997 Pop_Scope;
5998 end if;
5999
6000 Set_Elaboration_Flag (N, Corresponding_Spec (N));
6001 Set_In_Package_Body (Spec_Id, False);
6002
6003 -- Set to encode entity names in package body before gigi is called
6004
6005 Qualify_Entity_Names (N);
6006
6007 if Ekind (Spec_Id) /= E_Generic_Package then
6008 Build_Finalizer
6009 (N => N,
6010 Clean_Stmts => No_List,
6011 Mark_Id => Empty,
6012 Top_Decls => No_List,
6013 Defer_Abort => False,
6014 Fin_Id => Fin_Id);
6015
6016 if Present (Fin_Id) then
6017 declare
6018 Body_Ent : Node_Id := Defining_Unit_Name (N);
6019
6020 begin
6021 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
6022 Body_Ent := Defining_Identifier (Body_Ent);
6023 end if;
6024
6025 Set_Finalizer (Body_Ent, Fin_Id);
6026 end;
6027 end if;
6028 end if;
6029
6030 Ghost_Mode := Save_Ghost_Mode;
6031 end Expand_N_Package_Body;
6032
6033 ----------------------------------
6034 -- Expand_N_Package_Declaration --
6035 ----------------------------------
6036
6037 -- Add call to Activate_Tasks if there are tasks declared and the package
6038 -- has no body. Note that in Ada 83 this may result in premature activation
6039 -- of some tasks, given that we cannot tell whether a body will eventually
6040 -- appear.
6041
6042 procedure Expand_N_Package_Declaration (N : Node_Id) is
6043 Id : constant Entity_Id := Defining_Entity (N);
6044 Spec : constant Node_Id := Specification (N);
6045 Decls : List_Id;
6046 Fin_Id : Entity_Id;
6047
6048 No_Body : Boolean := False;
6049 -- True in the case of a package declaration that is a compilation
6050 -- unit and for which no associated body will be compiled in this
6051 -- compilation.
6052
6053 begin
6054 -- Case of a package declaration other than a compilation unit
6055
6056 if Nkind (Parent (N)) /= N_Compilation_Unit then
6057 null;
6058
6059 -- Case of a compilation unit that does not require a body
6060
6061 elsif not Body_Required (Parent (N))
6062 and then not Unit_Requires_Body (Id)
6063 then
6064 No_Body := True;
6065
6066 -- Special case of generating calling stubs for a remote call interface
6067 -- package: even though the package declaration requires one, the body
6068 -- won't be processed in this compilation (so any stubs for RACWs
6069 -- declared in the package must be generated here, along with the spec).
6070
6071 elsif Parent (N) = Cunit (Main_Unit)
6072 and then Is_Remote_Call_Interface (Id)
6073 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
6074 then
6075 No_Body := True;
6076 end if;
6077
6078 -- For a nested instance, delay processing until freeze point
6079
6080 if Has_Delayed_Freeze (Id)
6081 and then Nkind (Parent (N)) /= N_Compilation_Unit
6082 then
6083 return;
6084 end if;
6085
6086 -- For a package declaration that implies no associated body, generate
6087 -- task activation call and RACW supporting bodies now (since we won't
6088 -- have a specific separate compilation unit for that).
6089
6090 if No_Body then
6091 Push_Scope (Id);
6092
6093 -- Generate RACW subprogram bodies
6094
6095 if Has_RACW (Id) then
6096 Decls := Private_Declarations (Spec);
6097
6098 if No (Decls) then
6099 Decls := Visible_Declarations (Spec);
6100 end if;
6101
6102 if No (Decls) then
6103 Decls := New_List;
6104 Set_Visible_Declarations (Spec, Decls);
6105 end if;
6106
6107 Append_RACW_Bodies (Decls, Id);
6108 Analyze_List (Decls);
6109 end if;
6110
6111 -- Generate task activation call as last step of elaboration
6112
6113 if Present (Activation_Chain_Entity (N)) then
6114 Build_Task_Activation_Call (N);
6115 end if;
6116
6117 -- When the package is subject to pragma Initial_Condition and lacks
6118 -- a body, the assertion expression must be verified at the end of
6119 -- the visible declarations. Otherwise the check is performed at the
6120 -- end of the body statements (see Expand_N_Package_Body).
6121
6122 if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then
6123 Expand_Pragma_Initial_Condition (N);
6124 end if;
6125
6126 Pop_Scope;
6127 end if;
6128
6129 -- Build dispatch tables of library level tagged types
6130
6131 if Tagged_Type_Expansion
6132 and then (Is_Compilation_Unit (Id)
6133 or else (Is_Generic_Instance (Id)
6134 and then Is_Library_Level_Entity (Id)))
6135 then
6136 Build_Static_Dispatch_Tables (N);
6137 end if;
6138
6139 -- Note: it is not necessary to worry about generating a subprogram
6140 -- descriptor, since the only way to get exception handlers into a
6141 -- package spec is to include instantiations, and that would cause
6142 -- generation of subprogram descriptors to be delayed in any case.
6143
6144 -- Set to encode entity names in package spec before gigi is called
6145
6146 Qualify_Entity_Names (N);
6147
6148 if Ekind (Id) /= E_Generic_Package then
6149 Build_Finalizer
6150 (N => N,
6151 Clean_Stmts => No_List,
6152 Mark_Id => Empty,
6153 Top_Decls => No_List,
6154 Defer_Abort => False,
6155 Fin_Id => Fin_Id);
6156
6157 Set_Finalizer (Id, Fin_Id);
6158 end if;
6159 end Expand_N_Package_Declaration;
6160
6161 -----------------------------
6162 -- Find_Node_To_Be_Wrapped --
6163 -----------------------------
6164
6165 function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
6166 P : Node_Id;
6167 The_Parent : Node_Id;
6168
6169 begin
6170 The_Parent := N;
6171 P := Empty;
6172 loop
6173 case Nkind (The_Parent) is
6174
6175 -- Simple statement can be wrapped
6176
6177 when N_Pragma =>
6178 return The_Parent;
6179
6180 -- Usually assignments are good candidate for wrapping except
6181 -- when they have been generated as part of a controlled aggregate
6182 -- where the wrapping should take place more globally. Note that
6183 -- No_Ctrl_Actions may be set also for non-controlled assignements
6184 -- in order to disable the use of dispatching _assign, so we need
6185 -- to test explicitly for a controlled type here.
6186
6187 when N_Assignment_Statement =>
6188 if No_Ctrl_Actions (The_Parent)
6189 and then Needs_Finalization (Etype (Name (The_Parent)))
6190 then
6191 null;
6192 else
6193 return The_Parent;
6194 end if;
6195
6196 -- An entry call statement is a special case if it occurs in the
6197 -- context of a Timed_Entry_Call. In this case we wrap the entire
6198 -- timed entry call.
6199
6200 when N_Entry_Call_Statement |
6201 N_Procedure_Call_Statement =>
6202 if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
6203 and then Nkind_In (Parent (Parent (The_Parent)),
6204 N_Timed_Entry_Call,
6205 N_Conditional_Entry_Call)
6206 then
6207 return Parent (Parent (The_Parent));
6208 else
6209 return The_Parent;
6210 end if;
6211
6212 -- Object declarations are also a boundary for the transient scope
6213 -- even if they are not really wrapped. For further details, see
6214 -- Wrap_Transient_Declaration.
6215
6216 when N_Object_Declaration |
6217 N_Object_Renaming_Declaration |
6218 N_Subtype_Declaration =>
6219 return The_Parent;
6220
6221 -- The expression itself is to be wrapped if its parent is a
6222 -- compound statement or any other statement where the expression
6223 -- is known to be scalar.
6224
6225 when N_Accept_Alternative |
6226 N_Attribute_Definition_Clause |
6227 N_Case_Statement |
6228 N_Code_Statement |
6229 N_Delay_Alternative |
6230 N_Delay_Until_Statement |
6231 N_Delay_Relative_Statement |
6232 N_Discriminant_Association |
6233 N_Elsif_Part |
6234 N_Entry_Body_Formal_Part |
6235 N_Exit_Statement |
6236 N_If_Statement |
6237 N_Iteration_Scheme |
6238 N_Terminate_Alternative =>
6239 pragma Assert (Present (P));
6240 return P;
6241
6242 when N_Attribute_Reference =>
6243
6244 if Is_Procedure_Attribute_Name
6245 (Attribute_Name (The_Parent))
6246 then
6247 return The_Parent;
6248 end if;
6249
6250 -- A raise statement can be wrapped. This will arise when the
6251 -- expression in a raise_with_expression uses the secondary
6252 -- stack, for example.
6253
6254 when N_Raise_Statement =>
6255 return The_Parent;
6256
6257 -- If the expression is within the iteration scheme of a loop,
6258 -- we must create a declaration for it, followed by an assignment
6259 -- in order to have a usable statement to wrap.
6260
6261 when N_Loop_Parameter_Specification =>
6262 return Parent (The_Parent);
6263
6264 -- The following nodes contains "dummy calls" which don't need to
6265 -- be wrapped.
6266
6267 when N_Parameter_Specification |
6268 N_Discriminant_Specification |
6269 N_Component_Declaration =>
6270 return Empty;
6271
6272 -- The return statement is not to be wrapped when the function
6273 -- itself needs wrapping at the outer-level
6274
6275 when N_Simple_Return_Statement =>
6276 declare
6277 Applies_To : constant Entity_Id :=
6278 Return_Applies_To
6279 (Return_Statement_Entity (The_Parent));
6280 Return_Type : constant Entity_Id := Etype (Applies_To);
6281 begin
6282 if Requires_Transient_Scope (Return_Type) then
6283 return Empty;
6284 else
6285 return The_Parent;
6286 end if;
6287 end;
6288
6289 -- If we leave a scope without having been able to find a node to
6290 -- wrap, something is going wrong but this can happen in error
6291 -- situation that are not detected yet (such as a dynamic string
6292 -- in a pragma export)
6293
6294 when N_Subprogram_Body |
6295 N_Package_Declaration |
6296 N_Package_Body |
6297 N_Block_Statement =>
6298 return Empty;
6299
6300 -- Otherwise continue the search
6301
6302 when others =>
6303 null;
6304 end case;
6305
6306 P := The_Parent;
6307 The_Parent := Parent (P);
6308 end loop;
6309 end Find_Node_To_Be_Wrapped;
6310
6311 ----------------------------------
6312 -- Has_New_Controlled_Component --
6313 ----------------------------------
6314
6315 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
6316 Comp : Entity_Id;
6317
6318 begin
6319 if not Is_Tagged_Type (E) then
6320 return Has_Controlled_Component (E);
6321 elsif not Is_Derived_Type (E) then
6322 return Has_Controlled_Component (E);
6323 end if;
6324
6325 Comp := First_Component (E);
6326 while Present (Comp) loop
6327 if Chars (Comp) = Name_uParent then
6328 null;
6329
6330 elsif Scope (Original_Record_Component (Comp)) = E
6331 and then Needs_Finalization (Etype (Comp))
6332 then
6333 return True;
6334 end if;
6335
6336 Next_Component (Comp);
6337 end loop;
6338
6339 return False;
6340 end Has_New_Controlled_Component;
6341
6342 ---------------------------------
6343 -- Has_Simple_Protected_Object --
6344 ---------------------------------
6345
6346 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
6347 begin
6348 if Has_Task (T) then
6349 return False;
6350
6351 elsif Is_Simple_Protected_Type (T) then
6352 return True;
6353
6354 elsif Is_Array_Type (T) then
6355 return Has_Simple_Protected_Object (Component_Type (T));
6356
6357 elsif Is_Record_Type (T) then
6358 declare
6359 Comp : Entity_Id;
6360
6361 begin
6362 Comp := First_Component (T);
6363 while Present (Comp) loop
6364 if Has_Simple_Protected_Object (Etype (Comp)) then
6365 return True;
6366 end if;
6367
6368 Next_Component (Comp);
6369 end loop;
6370
6371 return False;
6372 end;
6373
6374 else
6375 return False;
6376 end if;
6377 end Has_Simple_Protected_Object;
6378
6379 ------------------------------------
6380 -- Insert_Actions_In_Scope_Around --
6381 ------------------------------------
6382
6383 procedure Insert_Actions_In_Scope_Around
6384 (N : Node_Id;
6385 Clean : Boolean;
6386 Manage_SS : Boolean)
6387 is
6388 Act_Before : constant List_Id :=
6389 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
6390 Act_After : constant List_Id :=
6391 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
6392 Act_Cleanup : constant List_Id :=
6393 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
6394 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
6395 -- Last), but this was incorrect as Process_Transient_Object may
6396 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
6397
6398 procedure Process_Transient_Objects
6399 (First_Object : Node_Id;
6400 Last_Object : Node_Id;
6401 Related_Node : Node_Id);
6402 -- First_Object and Last_Object define a list which contains potential
6403 -- controlled transient objects. Finalization flags are inserted before
6404 -- First_Object and finalization calls are inserted after Last_Object.
6405 -- Related_Node is the node for which transient objects have been
6406 -- created.
6407
6408 -------------------------------
6409 -- Process_Transient_Objects --
6410 -------------------------------
6411
6412 procedure Process_Transient_Objects
6413 (First_Object : Node_Id;
6414 Last_Object : Node_Id;
6415 Related_Node : Node_Id)
6416 is
6417 Must_Hook : Boolean := False;
6418 -- Flag denoting whether the context requires transient variable
6419 -- export to the outer finalizer.
6420
6421 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
6422 -- Determine whether an arbitrary node denotes a subprogram call
6423
6424 procedure Detect_Subprogram_Call is
6425 new Traverse_Proc (Is_Subprogram_Call);
6426
6427 ------------------------
6428 -- Is_Subprogram_Call --
6429 ------------------------
6430
6431 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
6432 begin
6433 -- A regular procedure or function call
6434
6435 if Nkind (N) in N_Subprogram_Call then
6436 Must_Hook := True;
6437 return Abandon;
6438
6439 -- Special cases
6440
6441 -- Heavy expansion may relocate function calls outside the related
6442 -- node. Inspect the original node to detect the initial placement
6443 -- of the call.
6444
6445 elsif Original_Node (N) /= N then
6446 Detect_Subprogram_Call (Original_Node (N));
6447
6448 if Must_Hook then
6449 return Abandon;
6450 else
6451 return OK;
6452 end if;
6453
6454 -- Generalized indexing always involves a function call
6455
6456 elsif Nkind (N) = N_Indexed_Component
6457 and then Present (Generalized_Indexing (N))
6458 then
6459 Must_Hook := True;
6460 return Abandon;
6461
6462 -- Keep searching
6463
6464 else
6465 return OK;
6466 end if;
6467 end Is_Subprogram_Call;
6468
6469 -- Local variables
6470
6471 Exceptions_OK : constant Boolean :=
6472 not Restriction_Active (No_Exception_Propagation);
6473
6474 Built : Boolean := False;
6475 Blk_Decl : Node_Id := Empty;
6476 Blk_Decls : List_Id := No_List;
6477 Blk_Ins : Node_Id;
6478 Blk_Stmts : List_Id;
6479 Desig_Typ : Entity_Id;
6480 Fin_Call : Node_Id;
6481 Fin_Data : Finalization_Exception_Data;
6482 Fin_Stmts : List_Id;
6483 Hook_Clr : Node_Id := Empty;
6484 Hook_Id : Entity_Id;
6485 Hook_Ins : Node_Id;
6486 Init_Expr : Node_Id;
6487 Loc : Source_Ptr;
6488 Obj_Decl : Node_Id;
6489 Obj_Id : Entity_Id;
6490 Obj_Ref : Node_Id;
6491 Obj_Typ : Entity_Id;
6492 Ptr_Typ : Entity_Id;
6493
6494 -- Start of processing for Process_Transient_Objects
6495
6496 begin
6497 -- The expansion performed by this routine is as follows:
6498
6499 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
6500 -- Hook_1 : Ptr_Typ_1 := null;
6501 -- Ctrl_Trans_Obj_1 : ...;
6502 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
6503 -- . . .
6504 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
6505 -- Hook_N : Ptr_Typ_N := null;
6506 -- Ctrl_Trans_Obj_N : ...;
6507 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
6508
6509 -- declare
6510 -- Abrt : constant Boolean := ...;
6511 -- Ex : Exception_Occurrence;
6512 -- Raised : Boolean := False;
6513
6514 -- begin
6515 -- Abort_Defer;
6516
6517 -- begin
6518 -- Hook_N := null;
6519 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
6520
6521 -- exception
6522 -- when others =>
6523 -- if not Raised then
6524 -- Raised := True;
6525 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6526 -- end;
6527 -- . . .
6528 -- begin
6529 -- Hook_1 := null;
6530 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
6531
6532 -- exception
6533 -- when others =>
6534 -- if not Raised then
6535 -- Raised := True;
6536 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
6537 -- end;
6538
6539 -- if Raised and not Abrt then
6540 -- Raise_From_Controlled_Operation (Ex);
6541 -- end if;
6542
6543 -- Abort_Undefer_Direct;
6544 -- end;
6545
6546 -- Recognize a scenario where the transient context is an object
6547 -- declaration initialized by a build-in-place function call:
6548
6549 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
6550
6551 -- The rough expansion of the above is:
6552
6553 -- Temp : ... := Ctrl_Func_Call;
6554 -- Obj : ...;
6555 -- Res : ... := BIP_Func_Call (..., Obj, ...);
6556
6557 -- The finalization of any controlled transient must happen after
6558 -- the build-in-place function call is executed.
6559
6560 if Nkind (N) = N_Object_Declaration
6561 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
6562 then
6563 Must_Hook := True;
6564 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
6565
6566 -- Search the context for at least one subprogram call. If found, the
6567 -- machinery exports all transient objects to the enclosing finalizer
6568 -- due to the possibility of abnormal call termination.
6569
6570 else
6571 Detect_Subprogram_Call (N);
6572 Blk_Ins := Last_Object;
6573 end if;
6574
6575 if Clean then
6576 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
6577 end if;
6578
6579 -- Examine all objects in the list First_Object .. Last_Object
6580
6581 Obj_Decl := First_Object;
6582 while Present (Obj_Decl) loop
6583 if Nkind (Obj_Decl) = N_Object_Declaration
6584 and then Analyzed (Obj_Decl)
6585 and then Is_Finalizable_Transient (Obj_Decl, N)
6586
6587 -- Do not process the node to be wrapped since it will be
6588 -- handled by the enclosing finalizer.
6589
6590 and then Obj_Decl /= Related_Node
6591 then
6592 Loc := Sloc (Obj_Decl);
6593 Obj_Id := Defining_Identifier (Obj_Decl);
6594 Obj_Typ := Base_Type (Etype (Obj_Id));
6595 Desig_Typ := Obj_Typ;
6596
6597 Set_Is_Processed_Transient (Obj_Id);
6598
6599 -- Handle access types
6600
6601 if Is_Access_Type (Desig_Typ) then
6602 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
6603 end if;
6604
6605 -- Transient objects associated with subprogram calls need
6606 -- extra processing. These objects are usually created right
6607 -- before the call and finalized immediately after the call.
6608 -- If an exception occurs during the call, the clean up code
6609 -- is skipped due to the sudden change in control and the
6610 -- transient is never finalized.
6611
6612 -- To handle this case, such variables are "exported" to the
6613 -- enclosing sequence of statements where their corresponding
6614 -- "hooks" are picked up by the finalization machinery.
6615
6616 if Must_Hook then
6617
6618 -- Create an access type which provides a reference to the
6619 -- transient object. Generate:
6620 -- type Ptr_Typ is access [all] Desig_Typ;
6621
6622 Ptr_Typ := Make_Temporary (Loc, 'A');
6623
6624 Insert_Action (Obj_Decl,
6625 Make_Full_Type_Declaration (Loc,
6626 Defining_Identifier => Ptr_Typ,
6627 Type_Definition =>
6628 Make_Access_To_Object_Definition (Loc,
6629 All_Present =>
6630 Ekind (Obj_Typ) = E_General_Access_Type,
6631 Subtype_Indication =>
6632 New_Occurrence_Of (Desig_Typ, Loc))));
6633
6634 -- Create a temporary which acts as a hook to the transient
6635 -- object. Generate:
6636 -- Hook : Ptr_Typ := null;
6637
6638 Hook_Id := Make_Temporary (Loc, 'T');
6639
6640 Insert_Action (Obj_Decl,
6641 Make_Object_Declaration (Loc,
6642 Defining_Identifier => Hook_Id,
6643 Object_Definition =>
6644 New_Occurrence_Of (Ptr_Typ, Loc)));
6645
6646 -- Mark the temporary as a hook. This signals the machinery
6647 -- in Build_Finalizer to recognize this special case.
6648
6649 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
6650
6651 -- Hook the transient object to the temporary. Generate:
6652 -- Hook := Ptr_Typ (Obj_Id);
6653 -- <or>
6654 -- Hook := Obj_Id'Unrestricted_Access;
6655
6656 if Is_Access_Type (Obj_Typ) then
6657 Init_Expr :=
6658 Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
6659
6660 else
6661 Init_Expr :=
6662 Make_Attribute_Reference (Loc,
6663 Prefix => New_Occurrence_Of (Obj_Id, Loc),
6664 Attribute_Name => Name_Unrestricted_Access);
6665 end if;
6666
6667 -- When the transient object is initialized by an aggregate,
6668 -- the hook must capture the object after the last component
6669 -- assignment takes place. Only then is the object fully
6670 -- initialized.
6671
6672 if Ekind (Obj_Id) = E_Variable
6673 and then Present (Last_Aggregate_Assignment (Obj_Id))
6674 then
6675 Hook_Ins := Last_Aggregate_Assignment (Obj_Id);
6676
6677 -- Otherwise the hook seizes the related object immediately
6678
6679 else
6680 Hook_Ins := Obj_Decl;
6681 end if;
6682
6683 Insert_After_And_Analyze (Hook_Ins,
6684 Make_Assignment_Statement (Loc,
6685 Name => New_Occurrence_Of (Hook_Id, Loc),
6686 Expression => Init_Expr));
6687
6688 -- The transient object is about to be finalized by the
6689 -- clean up code following the subprogram call. In order
6690 -- to avoid double finalization, clear the hook.
6691
6692 -- Generate:
6693 -- Hook := null;
6694
6695 Hook_Clr :=
6696 Make_Assignment_Statement (Loc,
6697 Name => New_Occurrence_Of (Hook_Id, Loc),
6698 Expression => Make_Null (Loc));
6699 end if;
6700
6701 -- Before generating the clean up code for the first transient
6702 -- object, create a wrapper block which houses all hook clear
6703 -- statements and finalization calls. This wrapper is needed by
6704 -- the back-end.
6705
6706 if not Built then
6707 Built := True;
6708 Blk_Stmts := New_List;
6709
6710 -- Create the declarations of all entities that participate
6711 -- in exception detection and propagation.
6712
6713 if Exceptions_OK then
6714 Blk_Decls := New_List;
6715
6716 -- Generate:
6717 -- Abrt : constant Boolean := ...;
6718 -- Ex : Exception_Occurrence;
6719 -- Raised : Boolean := False;
6720
6721 Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
6722
6723 -- Generate:
6724 -- if Raised and then not Abrt then
6725 -- Raise_From_Controlled_Operation (Ex);
6726 -- end if;
6727
6728 Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
6729 end if;
6730
6731 Blk_Decl :=
6732 Make_Block_Statement (Loc,
6733 Declarations => Blk_Decls,
6734 Handled_Statement_Sequence =>
6735 Make_Handled_Sequence_Of_Statements (Loc,
6736 Statements => Blk_Stmts));
6737 end if;
6738
6739 -- Generate:
6740 -- [Deep_]Finalize (Obj_Ref);
6741
6742 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
6743
6744 if Is_Access_Type (Obj_Typ) then
6745 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
6746 Set_Etype (Obj_Ref, Desig_Typ);
6747 end if;
6748
6749 Fin_Call :=
6750 Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
6751
6752 -- When exception propagation is enabled wrap the hook clear
6753 -- statement and the finalization call into a block to catch
6754 -- potential exceptions raised during finalization. Generate:
6755
6756 -- begin
6757 -- [Temp := null;]
6758 -- [Deep_]Finalize (Obj_Ref);
6759
6760 -- exception
6761 -- when others =>
6762 -- if not Raised then
6763 -- Raised := True;
6764 -- Save_Occurrence
6765 -- (Enn, Get_Current_Excep.all.all);
6766 -- end if;
6767 -- end;
6768
6769 if Exceptions_OK then
6770 Fin_Stmts := New_List;
6771
6772 if Present (Hook_Clr) then
6773 Append_To (Fin_Stmts, Hook_Clr);
6774 end if;
6775
6776 Append_To (Fin_Stmts, Fin_Call);
6777
6778 Prepend_To (Blk_Stmts,
6779 Make_Block_Statement (Loc,
6780 Handled_Statement_Sequence =>
6781 Make_Handled_Sequence_Of_Statements (Loc,
6782 Statements => Fin_Stmts,
6783 Exception_Handlers => New_List (
6784 Build_Exception_Handler (Fin_Data)))));
6785
6786 -- Otherwise generate:
6787 -- [Temp := null;]
6788 -- [Deep_]Finalize (Obj_Ref);
6789
6790 else
6791 Prepend_To (Blk_Stmts, Fin_Call);
6792
6793 if Present (Hook_Clr) then
6794 Prepend_To (Blk_Stmts, Hook_Clr);
6795 end if;
6796 end if;
6797 end if;
6798
6799 -- Terminate the scan after the last object has been processed to
6800 -- avoid touching unrelated code.
6801
6802 if Obj_Decl = Last_Object then
6803 exit;
6804 end if;
6805
6806 Next (Obj_Decl);
6807 end loop;
6808
6809 if Present (Blk_Decl) then
6810
6811 -- Note that the abort defer / undefer pair does not require an
6812 -- extra block because each finalization exception is caught in
6813 -- its corresponding finalization block. As a result, the call to
6814 -- Abort_Defer always takes place.
6815
6816 if Abort_Allowed then
6817 Prepend_To (Blk_Stmts,
6818 Build_Runtime_Call (Loc, RE_Abort_Defer));
6819
6820 Append_To (Blk_Stmts,
6821 Build_Runtime_Call (Loc, RE_Abort_Undefer));
6822 end if;
6823
6824 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
6825 end if;
6826 end Process_Transient_Objects;
6827
6828 -- Local variables
6829
6830 Loc : constant Source_Ptr := Sloc (N);
6831 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
6832 First_Obj : Node_Id;
6833 Last_Obj : Node_Id;
6834 Mark_Id : Entity_Id;
6835 Target : Node_Id;
6836
6837 -- Start of processing for Insert_Actions_In_Scope_Around
6838
6839 begin
6840 if No (Act_Before) and then No (Act_After) and then No (Act_Cleanup) then
6841 return;
6842 end if;
6843
6844 -- If the node to be wrapped is the trigger of an asynchronous select,
6845 -- it is not part of a statement list. The actions must be inserted
6846 -- before the select itself, which is part of some list of statements.
6847 -- Note that the triggering alternative includes the triggering
6848 -- statement and an optional statement list. If the node to be
6849 -- wrapped is part of that list, the normal insertion applies.
6850
6851 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
6852 and then not Is_List_Member (Node_To_Wrap)
6853 then
6854 Target := Parent (Parent (Node_To_Wrap));
6855 else
6856 Target := N;
6857 end if;
6858
6859 First_Obj := Target;
6860 Last_Obj := Target;
6861
6862 -- Add all actions associated with a transient scope into the main tree.
6863 -- There are several scenarios here:
6864
6865 -- +--- Before ----+ +----- After ---+
6866 -- 1) First_Obj ....... Target ........ Last_Obj
6867
6868 -- 2) First_Obj ....... Target
6869
6870 -- 3) Target ........ Last_Obj
6871
6872 -- Flag declarations are inserted before the first object
6873
6874 if Present (Act_Before) then
6875 First_Obj := First (Act_Before);
6876 Insert_List_Before (Target, Act_Before);
6877 end if;
6878
6879 -- Finalization calls are inserted after the last object
6880
6881 if Present (Act_After) then
6882 Last_Obj := Last (Act_After);
6883 Insert_List_After (Target, Act_After);
6884 end if;
6885
6886 -- Mark and release the secondary stack when the context warrants it
6887
6888 if Manage_SS then
6889 Mark_Id := Make_Temporary (Loc, 'M');
6890
6891 -- Generate:
6892 -- Mnn : constant Mark_Id := SS_Mark;
6893
6894 Insert_Before_And_Analyze
6895 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
6896
6897 -- Generate:
6898 -- SS_Release (Mnn);
6899
6900 Insert_After_And_Analyze
6901 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
6902 end if;
6903
6904 -- Check for transient controlled objects associated with Target and
6905 -- generate the appropriate finalization actions for them.
6906
6907 Process_Transient_Objects
6908 (First_Object => First_Obj,
6909 Last_Object => Last_Obj,
6910 Related_Node => Target);
6911
6912 -- Reset the action lists
6913
6914 Scope_Stack.Table
6915 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
6916 Scope_Stack.Table
6917 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
6918
6919 if Clean then
6920 Scope_Stack.Table
6921 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
6922 end if;
6923 end Insert_Actions_In_Scope_Around;
6924
6925 ------------------------------
6926 -- Is_Simple_Protected_Type --
6927 ------------------------------
6928
6929 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
6930 begin
6931 return
6932 Is_Protected_Type (T)
6933 and then not Uses_Lock_Free (T)
6934 and then not Has_Entries (T)
6935 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
6936 end Is_Simple_Protected_Type;
6937
6938 -----------------------
6939 -- Make_Adjust_Call --
6940 -----------------------
6941
6942 function Make_Adjust_Call
6943 (Obj_Ref : Node_Id;
6944 Typ : Entity_Id;
6945 Skip_Self : Boolean := False) return Node_Id
6946 is
6947 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6948 Adj_Id : Entity_Id := Empty;
6949 Ref : Node_Id := Obj_Ref;
6950 Utyp : Entity_Id;
6951
6952 begin
6953 -- Recover the proper type which contains Deep_Adjust
6954
6955 if Is_Class_Wide_Type (Typ) then
6956 Utyp := Root_Type (Typ);
6957 else
6958 Utyp := Typ;
6959 end if;
6960
6961 Utyp := Underlying_Type (Base_Type (Utyp));
6962 Set_Assignment_OK (Ref);
6963
6964 -- Deal with untagged derivation of private views
6965
6966 if Is_Untagged_Derivation (Typ) then
6967 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6968 Ref := Unchecked_Convert_To (Utyp, Ref);
6969 Set_Assignment_OK (Ref);
6970 end if;
6971
6972 -- When dealing with the completion of a private type, use the base
6973 -- type instead.
6974
6975 if Utyp /= Base_Type (Utyp) then
6976 pragma Assert (Is_Private_Type (Typ));
6977
6978 Utyp := Base_Type (Utyp);
6979 Ref := Unchecked_Convert_To (Utyp, Ref);
6980 end if;
6981
6982 if Skip_Self then
6983 if Has_Controlled_Component (Utyp) then
6984 if Is_Tagged_Type (Utyp) then
6985 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6986 else
6987 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6988 end if;
6989 end if;
6990
6991 -- Class-wide types, interfaces and types with controlled components
6992
6993 elsif Is_Class_Wide_Type (Typ)
6994 or else Is_Interface (Typ)
6995 or else Has_Controlled_Component (Utyp)
6996 then
6997 if Is_Tagged_Type (Utyp) then
6998 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6999 else
7000 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
7001 end if;
7002
7003 -- Derivations from [Limited_]Controlled
7004
7005 elsif Is_Controlled (Utyp) then
7006 if Has_Controlled_Component (Utyp) then
7007 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
7008 else
7009 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
7010 end if;
7011
7012 -- Tagged types
7013
7014 elsif Is_Tagged_Type (Utyp) then
7015 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
7016
7017 else
7018 raise Program_Error;
7019 end if;
7020
7021 if Present (Adj_Id) then
7022
7023 -- If the object is unanalyzed, set its expected type for use in
7024 -- Convert_View in case an additional conversion is needed.
7025
7026 if No (Etype (Ref))
7027 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
7028 then
7029 Set_Etype (Ref, Typ);
7030 end if;
7031
7032 -- The object reference may need another conversion depending on the
7033 -- type of the formal and that of the actual.
7034
7035 if not Is_Class_Wide_Type (Typ) then
7036 Ref := Convert_View (Adj_Id, Ref);
7037 end if;
7038
7039 return
7040 Make_Call (Loc,
7041 Proc_Id => Adj_Id,
7042 Param => New_Copy_Tree (Ref),
7043 Skip_Self => Skip_Self);
7044 else
7045 return Empty;
7046 end if;
7047 end Make_Adjust_Call;
7048
7049 ----------------------
7050 -- Make_Detach_Call --
7051 ----------------------
7052
7053 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
7054 Loc : constant Source_Ptr := Sloc (Obj_Ref);
7055
7056 begin
7057 return
7058 Make_Procedure_Call_Statement (Loc,
7059 Name =>
7060 New_Occurrence_Of (RTE (RE_Detach), Loc),
7061 Parameter_Associations => New_List (
7062 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
7063 end Make_Detach_Call;
7064
7065 ---------------
7066 -- Make_Call --
7067 ---------------
7068
7069 function Make_Call
7070 (Loc : Source_Ptr;
7071 Proc_Id : Entity_Id;
7072 Param : Node_Id;
7073 Skip_Self : Boolean := False) return Node_Id
7074 is
7075 Params : constant List_Id := New_List (Param);
7076
7077 begin
7078 -- Do not apply the controlled action to the object itself by signaling
7079 -- the related routine to avoid self.
7080
7081 if Skip_Self then
7082 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
7083 end if;
7084
7085 return
7086 Make_Procedure_Call_Statement (Loc,
7087 Name => New_Occurrence_Of (Proc_Id, Loc),
7088 Parameter_Associations => Params);
7089 end Make_Call;
7090
7091 --------------------------
7092 -- Make_Deep_Array_Body --
7093 --------------------------
7094
7095 function Make_Deep_Array_Body
7096 (Prim : Final_Primitives;
7097 Typ : Entity_Id) return List_Id
7098 is
7099 function Build_Adjust_Or_Finalize_Statements
7100 (Typ : Entity_Id) return List_Id;
7101 -- Create the statements necessary to adjust or finalize an array of
7102 -- controlled elements. Generate:
7103 --
7104 -- declare
7105 -- Abort : constant Boolean := Triggered_By_Abort;
7106 -- <or>
7107 -- Abort : constant Boolean := False; -- no abort
7108 --
7109 -- E : Exception_Occurrence;
7110 -- Raised : Boolean := False;
7111 --
7112 -- begin
7113 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
7114 -- ^-- in the finalization case
7115 -- ...
7116 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
7117 -- begin
7118 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
7119 --
7120 -- exception
7121 -- when others =>
7122 -- if not Raised then
7123 -- Raised := True;
7124 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7125 -- end if;
7126 -- end;
7127 -- end loop;
7128 -- ...
7129 -- end loop;
7130 --
7131 -- if Raised and then not Abort then
7132 -- Raise_From_Controlled_Operation (E);
7133 -- end if;
7134 -- end;
7135
7136 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
7137 -- Create the statements necessary to initialize an array of controlled
7138 -- elements. Include a mechanism to carry out partial finalization if an
7139 -- exception occurs. Generate:
7140 --
7141 -- declare
7142 -- Counter : Integer := 0;
7143 --
7144 -- begin
7145 -- for J1 in V'Range (1) loop
7146 -- ...
7147 -- for JN in V'Range (N) loop
7148 -- begin
7149 -- [Deep_]Initialize (V (J1, ..., JN));
7150 --
7151 -- Counter := Counter + 1;
7152 --
7153 -- exception
7154 -- when others =>
7155 -- declare
7156 -- Abort : constant Boolean := Triggered_By_Abort;
7157 -- <or>
7158 -- Abort : constant Boolean := False; -- no abort
7159 -- E : Exception_Occurrence;
7160 -- Raised : Boolean := False;
7161
7162 -- begin
7163 -- Counter :=
7164 -- V'Length (1) *
7165 -- V'Length (2) *
7166 -- ...
7167 -- V'Length (N) - Counter;
7168
7169 -- for F1 in reverse V'Range (1) loop
7170 -- ...
7171 -- for FN in reverse V'Range (N) loop
7172 -- if Counter > 0 then
7173 -- Counter := Counter - 1;
7174 -- else
7175 -- begin
7176 -- [Deep_]Finalize (V (F1, ..., FN));
7177
7178 -- exception
7179 -- when others =>
7180 -- if not Raised then
7181 -- Raised := True;
7182 -- Save_Occurrence (E,
7183 -- Get_Current_Excep.all.all);
7184 -- end if;
7185 -- end;
7186 -- end if;
7187 -- end loop;
7188 -- ...
7189 -- end loop;
7190 -- end;
7191 --
7192 -- if Raised and then not Abort then
7193 -- Raise_From_Controlled_Operation (E);
7194 -- end if;
7195 --
7196 -- raise;
7197 -- end;
7198 -- end loop;
7199 -- end loop;
7200 -- end;
7201
7202 function New_References_To
7203 (L : List_Id;
7204 Loc : Source_Ptr) return List_Id;
7205 -- Given a list of defining identifiers, return a list of references to
7206 -- the original identifiers, in the same order as they appear.
7207
7208 -----------------------------------------
7209 -- Build_Adjust_Or_Finalize_Statements --
7210 -----------------------------------------
7211
7212 function Build_Adjust_Or_Finalize_Statements
7213 (Typ : Entity_Id) return List_Id
7214 is
7215 Comp_Typ : constant Entity_Id := Component_Type (Typ);
7216 Exceptions_OK : constant Boolean :=
7217 not Restriction_Active (No_Exception_Propagation);
7218 Index_List : constant List_Id := New_List;
7219 Loc : constant Source_Ptr := Sloc (Typ);
7220 Num_Dims : constant Int := Number_Dimensions (Typ);
7221
7222 Finalizer_Decls : List_Id := No_List;
7223 Finalizer_Data : Finalization_Exception_Data;
7224 Call : Node_Id;
7225 Comp_Ref : Node_Id;
7226 Core_Loop : Node_Id;
7227 Dim : Int;
7228 J : Entity_Id;
7229 Loop_Id : Entity_Id;
7230 Stmts : List_Id;
7231
7232 procedure Build_Indexes;
7233 -- Generate the indexes used in the dimension loops
7234
7235 -------------------
7236 -- Build_Indexes --
7237 -------------------
7238
7239 procedure Build_Indexes is
7240 begin
7241 -- Generate the following identifiers:
7242 -- Jnn - for initialization
7243
7244 for Dim in 1 .. Num_Dims loop
7245 Append_To (Index_List,
7246 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
7247 end loop;
7248 end Build_Indexes;
7249
7250 -- Start of processing for Build_Adjust_Or_Finalize_Statements
7251
7252 begin
7253 Finalizer_Decls := New_List;
7254
7255 Build_Indexes;
7256 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7257
7258 Comp_Ref :=
7259 Make_Indexed_Component (Loc,
7260 Prefix => Make_Identifier (Loc, Name_V),
7261 Expressions => New_References_To (Index_List, Loc));
7262 Set_Etype (Comp_Ref, Comp_Typ);
7263
7264 -- Generate:
7265 -- [Deep_]Adjust (V (J1, ..., JN))
7266
7267 if Prim = Adjust_Case then
7268 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7269
7270 -- Generate:
7271 -- [Deep_]Finalize (V (J1, ..., JN))
7272
7273 else pragma Assert (Prim = Finalize_Case);
7274 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7275 end if;
7276
7277 -- Generate the block which houses the adjust or finalize call:
7278
7279 -- begin
7280 -- <adjust or finalize call>
7281
7282 -- exception
7283 -- when others =>
7284 -- if not Raised then
7285 -- Raised := True;
7286 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7287 -- end if;
7288 -- end;
7289
7290 if Exceptions_OK then
7291 Core_Loop :=
7292 Make_Block_Statement (Loc,
7293 Handled_Statement_Sequence =>
7294 Make_Handled_Sequence_Of_Statements (Loc,
7295 Statements => New_List (Call),
7296 Exception_Handlers => New_List (
7297 Build_Exception_Handler (Finalizer_Data))));
7298 else
7299 Core_Loop := Call;
7300 end if;
7301
7302 -- Generate the dimension loops starting from the innermost one
7303
7304 -- for Jnn in [reverse] V'Range (Dim) loop
7305 -- <core loop>
7306 -- end loop;
7307
7308 J := Last (Index_List);
7309 Dim := Num_Dims;
7310 while Present (J) and then Dim > 0 loop
7311 Loop_Id := J;
7312 Prev (J);
7313 Remove (Loop_Id);
7314
7315 Core_Loop :=
7316 Make_Loop_Statement (Loc,
7317 Iteration_Scheme =>
7318 Make_Iteration_Scheme (Loc,
7319 Loop_Parameter_Specification =>
7320 Make_Loop_Parameter_Specification (Loc,
7321 Defining_Identifier => Loop_Id,
7322 Discrete_Subtype_Definition =>
7323 Make_Attribute_Reference (Loc,
7324 Prefix => Make_Identifier (Loc, Name_V),
7325 Attribute_Name => Name_Range,
7326 Expressions => New_List (
7327 Make_Integer_Literal (Loc, Dim))),
7328
7329 Reverse_Present => Prim = Finalize_Case)),
7330
7331 Statements => New_List (Core_Loop),
7332 End_Label => Empty);
7333
7334 Dim := Dim - 1;
7335 end loop;
7336
7337 -- Generate the block which contains the core loop, the declarations
7338 -- of the abort flag, the exception occurrence, the raised flag and
7339 -- the conditional raise:
7340
7341 -- declare
7342 -- Abort : constant Boolean := Triggered_By_Abort;
7343 -- <or>
7344 -- Abort : constant Boolean := False; -- no abort
7345
7346 -- E : Exception_Occurrence;
7347 -- Raised : Boolean := False;
7348
7349 -- begin
7350 -- <core loop>
7351
7352 -- if Raised and then not Abort then
7353 -- Raise_From_Controlled_Operation (E);
7354 -- end if;
7355 -- end;
7356
7357 Stmts := New_List (Core_Loop);
7358
7359 if Exceptions_OK then
7360 Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
7361 end if;
7362
7363 return
7364 New_List (
7365 Make_Block_Statement (Loc,
7366 Declarations =>
7367 Finalizer_Decls,
7368 Handled_Statement_Sequence =>
7369 Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
7370 end Build_Adjust_Or_Finalize_Statements;
7371
7372 ---------------------------------
7373 -- Build_Initialize_Statements --
7374 ---------------------------------
7375
7376 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
7377 Comp_Typ : constant Entity_Id := Component_Type (Typ);
7378 Exceptions_OK : constant Boolean :=
7379 not Restriction_Active (No_Exception_Propagation);
7380 Final_List : constant List_Id := New_List;
7381 Index_List : constant List_Id := New_List;
7382 Loc : constant Source_Ptr := Sloc (Typ);
7383 Num_Dims : constant Int := Number_Dimensions (Typ);
7384
7385 Counter_Id : Entity_Id;
7386 Dim : Int;
7387 F : Node_Id;
7388 Fin_Stmt : Node_Id;
7389 Final_Block : Node_Id;
7390 Final_Loop : Node_Id;
7391 Finalizer_Data : Finalization_Exception_Data;
7392 Finalizer_Decls : List_Id := No_List;
7393 Init_Loop : Node_Id;
7394 J : Node_Id;
7395 Loop_Id : Node_Id;
7396 Stmts : List_Id;
7397
7398 function Build_Counter_Assignment return Node_Id;
7399 -- Generate the following assignment:
7400 -- Counter := V'Length (1) *
7401 -- ...
7402 -- V'Length (N) - Counter;
7403
7404 function Build_Finalization_Call return Node_Id;
7405 -- Generate a deep finalization call for an array element
7406
7407 procedure Build_Indexes;
7408 -- Generate the initialization and finalization indexes used in the
7409 -- dimension loops.
7410
7411 function Build_Initialization_Call return Node_Id;
7412 -- Generate a deep initialization call for an array element
7413
7414 ------------------------------
7415 -- Build_Counter_Assignment --
7416 ------------------------------
7417
7418 function Build_Counter_Assignment return Node_Id is
7419 Dim : Int;
7420 Expr : Node_Id;
7421
7422 begin
7423 -- Start from the first dimension and generate:
7424 -- V'Length (1)
7425
7426 Dim := 1;
7427 Expr :=
7428 Make_Attribute_Reference (Loc,
7429 Prefix => Make_Identifier (Loc, Name_V),
7430 Attribute_Name => Name_Length,
7431 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
7432
7433 -- Process the rest of the dimensions, generate:
7434 -- Expr * V'Length (N)
7435
7436 Dim := Dim + 1;
7437 while Dim <= Num_Dims loop
7438 Expr :=
7439 Make_Op_Multiply (Loc,
7440 Left_Opnd => Expr,
7441 Right_Opnd =>
7442 Make_Attribute_Reference (Loc,
7443 Prefix => Make_Identifier (Loc, Name_V),
7444 Attribute_Name => Name_Length,
7445 Expressions => New_List (
7446 Make_Integer_Literal (Loc, Dim))));
7447
7448 Dim := Dim + 1;
7449 end loop;
7450
7451 -- Generate:
7452 -- Counter := Expr - Counter;
7453
7454 return
7455 Make_Assignment_Statement (Loc,
7456 Name => New_Occurrence_Of (Counter_Id, Loc),
7457 Expression =>
7458 Make_Op_Subtract (Loc,
7459 Left_Opnd => Expr,
7460 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
7461 end Build_Counter_Assignment;
7462
7463 -----------------------------
7464 -- Build_Finalization_Call --
7465 -----------------------------
7466
7467 function Build_Finalization_Call return Node_Id is
7468 Comp_Ref : constant Node_Id :=
7469 Make_Indexed_Component (Loc,
7470 Prefix => Make_Identifier (Loc, Name_V),
7471 Expressions => New_References_To (Final_List, Loc));
7472
7473 begin
7474 Set_Etype (Comp_Ref, Comp_Typ);
7475
7476 -- Generate:
7477 -- [Deep_]Finalize (V);
7478
7479 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7480 end Build_Finalization_Call;
7481
7482 -------------------
7483 -- Build_Indexes --
7484 -------------------
7485
7486 procedure Build_Indexes is
7487 begin
7488 -- Generate the following identifiers:
7489 -- Jnn - for initialization
7490 -- Fnn - for finalization
7491
7492 for Dim in 1 .. Num_Dims loop
7493 Append_To (Index_List,
7494 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
7495
7496 Append_To (Final_List,
7497 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
7498 end loop;
7499 end Build_Indexes;
7500
7501 -------------------------------
7502 -- Build_Initialization_Call --
7503 -------------------------------
7504
7505 function Build_Initialization_Call return Node_Id is
7506 Comp_Ref : constant Node_Id :=
7507 Make_Indexed_Component (Loc,
7508 Prefix => Make_Identifier (Loc, Name_V),
7509 Expressions => New_References_To (Index_List, Loc));
7510
7511 begin
7512 Set_Etype (Comp_Ref, Comp_Typ);
7513
7514 -- Generate:
7515 -- [Deep_]Initialize (V (J1, ..., JN));
7516
7517 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
7518 end Build_Initialization_Call;
7519
7520 -- Start of processing for Build_Initialize_Statements
7521
7522 begin
7523 Counter_Id := Make_Temporary (Loc, 'C');
7524 Finalizer_Decls := New_List;
7525
7526 Build_Indexes;
7527 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7528
7529 -- Generate the block which houses the finalization call, the index
7530 -- guard and the handler which triggers Program_Error later on.
7531
7532 -- if Counter > 0 then
7533 -- Counter := Counter - 1;
7534 -- else
7535 -- begin
7536 -- [Deep_]Finalize (V (F1, ..., FN));
7537 -- exception
7538 -- when others =>
7539 -- if not Raised then
7540 -- Raised := True;
7541 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7542 -- end if;
7543 -- end;
7544 -- end if;
7545
7546 if Exceptions_OK then
7547 Fin_Stmt :=
7548 Make_Block_Statement (Loc,
7549 Handled_Statement_Sequence =>
7550 Make_Handled_Sequence_Of_Statements (Loc,
7551 Statements => New_List (Build_Finalization_Call),
7552 Exception_Handlers => New_List (
7553 Build_Exception_Handler (Finalizer_Data))));
7554 else
7555 Fin_Stmt := Build_Finalization_Call;
7556 end if;
7557
7558 -- This is the core of the loop, the dimension iterators are added
7559 -- one by one in reverse.
7560
7561 Final_Loop :=
7562 Make_If_Statement (Loc,
7563 Condition =>
7564 Make_Op_Gt (Loc,
7565 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
7566 Right_Opnd => Make_Integer_Literal (Loc, 0)),
7567
7568 Then_Statements => New_List (
7569 Make_Assignment_Statement (Loc,
7570 Name => New_Occurrence_Of (Counter_Id, Loc),
7571 Expression =>
7572 Make_Op_Subtract (Loc,
7573 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
7574 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
7575
7576 Else_Statements => New_List (Fin_Stmt));
7577
7578 -- Generate all finalization loops starting from the innermost
7579 -- dimension.
7580
7581 -- for Fnn in reverse V'Range (Dim) loop
7582 -- <final loop>
7583 -- end loop;
7584
7585 F := Last (Final_List);
7586 Dim := Num_Dims;
7587 while Present (F) and then Dim > 0 loop
7588 Loop_Id := F;
7589 Prev (F);
7590 Remove (Loop_Id);
7591
7592 Final_Loop :=
7593 Make_Loop_Statement (Loc,
7594 Iteration_Scheme =>
7595 Make_Iteration_Scheme (Loc,
7596 Loop_Parameter_Specification =>
7597 Make_Loop_Parameter_Specification (Loc,
7598 Defining_Identifier => Loop_Id,
7599 Discrete_Subtype_Definition =>
7600 Make_Attribute_Reference (Loc,
7601 Prefix => Make_Identifier (Loc, Name_V),
7602 Attribute_Name => Name_Range,
7603 Expressions => New_List (
7604 Make_Integer_Literal (Loc, Dim))),
7605
7606 Reverse_Present => True)),
7607
7608 Statements => New_List (Final_Loop),
7609 End_Label => Empty);
7610
7611 Dim := Dim - 1;
7612 end loop;
7613
7614 -- Generate the block which contains the finalization loops, the
7615 -- declarations of the abort flag, the exception occurrence, the
7616 -- raised flag and the conditional raise.
7617
7618 -- declare
7619 -- Abort : constant Boolean := Triggered_By_Abort;
7620 -- <or>
7621 -- Abort : constant Boolean := False; -- no abort
7622
7623 -- E : Exception_Occurrence;
7624 -- Raised : Boolean := False;
7625
7626 -- begin
7627 -- Counter :=
7628 -- V'Length (1) *
7629 -- ...
7630 -- V'Length (N) - Counter;
7631
7632 -- <final loop>
7633
7634 -- if Raised and then not Abort then
7635 -- Raise_From_Controlled_Operation (E);
7636 -- end if;
7637
7638 -- raise;
7639 -- end;
7640
7641 Stmts := New_List (Build_Counter_Assignment, Final_Loop);
7642
7643 if Exceptions_OK then
7644 Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
7645 Append_To (Stmts, Make_Raise_Statement (Loc));
7646 end if;
7647
7648 Final_Block :=
7649 Make_Block_Statement (Loc,
7650 Declarations =>
7651 Finalizer_Decls,
7652 Handled_Statement_Sequence =>
7653 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
7654
7655 -- Generate the block which contains the initialization call and
7656 -- the partial finalization code.
7657
7658 -- begin
7659 -- [Deep_]Initialize (V (J1, ..., JN));
7660
7661 -- Counter := Counter + 1;
7662
7663 -- exception
7664 -- when others =>
7665 -- <finalization code>
7666 -- end;
7667
7668 Init_Loop :=
7669 Make_Block_Statement (Loc,
7670 Handled_Statement_Sequence =>
7671 Make_Handled_Sequence_Of_Statements (Loc,
7672 Statements => New_List (Build_Initialization_Call),
7673 Exception_Handlers => New_List (
7674 Make_Exception_Handler (Loc,
7675 Exception_Choices => New_List (Make_Others_Choice (Loc)),
7676 Statements => New_List (Final_Block)))));
7677
7678 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
7679 Make_Assignment_Statement (Loc,
7680 Name => New_Occurrence_Of (Counter_Id, Loc),
7681 Expression =>
7682 Make_Op_Add (Loc,
7683 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
7684 Right_Opnd => Make_Integer_Literal (Loc, 1))));
7685
7686 -- Generate all initialization loops starting from the innermost
7687 -- dimension.
7688
7689 -- for Jnn in V'Range (Dim) loop
7690 -- <init loop>
7691 -- end loop;
7692
7693 J := Last (Index_List);
7694 Dim := Num_Dims;
7695 while Present (J) and then Dim > 0 loop
7696 Loop_Id := J;
7697 Prev (J);
7698 Remove (Loop_Id);
7699
7700 Init_Loop :=
7701 Make_Loop_Statement (Loc,
7702 Iteration_Scheme =>
7703 Make_Iteration_Scheme (Loc,
7704 Loop_Parameter_Specification =>
7705 Make_Loop_Parameter_Specification (Loc,
7706 Defining_Identifier => Loop_Id,
7707 Discrete_Subtype_Definition =>
7708 Make_Attribute_Reference (Loc,
7709 Prefix => Make_Identifier (Loc, Name_V),
7710 Attribute_Name => Name_Range,
7711 Expressions => New_List (
7712 Make_Integer_Literal (Loc, Dim))))),
7713
7714 Statements => New_List (Init_Loop),
7715 End_Label => Empty);
7716
7717 Dim := Dim - 1;
7718 end loop;
7719
7720 -- Generate the block which contains the counter variable and the
7721 -- initialization loops.
7722
7723 -- declare
7724 -- Counter : Integer := 0;
7725 -- begin
7726 -- <init loop>
7727 -- end;
7728
7729 return
7730 New_List (
7731 Make_Block_Statement (Loc,
7732 Declarations => New_List (
7733 Make_Object_Declaration (Loc,
7734 Defining_Identifier => Counter_Id,
7735 Object_Definition =>
7736 New_Occurrence_Of (Standard_Integer, Loc),
7737 Expression => Make_Integer_Literal (Loc, 0))),
7738
7739 Handled_Statement_Sequence =>
7740 Make_Handled_Sequence_Of_Statements (Loc,
7741 Statements => New_List (Init_Loop))));
7742 end Build_Initialize_Statements;
7743
7744 -----------------------
7745 -- New_References_To --
7746 -----------------------
7747
7748 function New_References_To
7749 (L : List_Id;
7750 Loc : Source_Ptr) return List_Id
7751 is
7752 Refs : constant List_Id := New_List;
7753 Id : Node_Id;
7754
7755 begin
7756 Id := First (L);
7757 while Present (Id) loop
7758 Append_To (Refs, New_Occurrence_Of (Id, Loc));
7759 Next (Id);
7760 end loop;
7761
7762 return Refs;
7763 end New_References_To;
7764
7765 -- Start of processing for Make_Deep_Array_Body
7766
7767 begin
7768 case Prim is
7769 when Address_Case =>
7770 return Make_Finalize_Address_Stmts (Typ);
7771
7772 when Adjust_Case |
7773 Finalize_Case =>
7774 return Build_Adjust_Or_Finalize_Statements (Typ);
7775
7776 when Initialize_Case =>
7777 return Build_Initialize_Statements (Typ);
7778 end case;
7779 end Make_Deep_Array_Body;
7780
7781 --------------------
7782 -- Make_Deep_Proc --
7783 --------------------
7784
7785 function Make_Deep_Proc
7786 (Prim : Final_Primitives;
7787 Typ : Entity_Id;
7788 Stmts : List_Id) return Entity_Id
7789 is
7790 Loc : constant Source_Ptr := Sloc (Typ);
7791 Formals : List_Id;
7792 Proc_Id : Entity_Id;
7793
7794 begin
7795 -- Create the object formal, generate:
7796 -- V : System.Address
7797
7798 if Prim = Address_Case then
7799 Formals := New_List (
7800 Make_Parameter_Specification (Loc,
7801 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7802 Parameter_Type =>
7803 New_Occurrence_Of (RTE (RE_Address), Loc)));
7804
7805 -- Default case
7806
7807 else
7808 -- V : in out Typ
7809
7810 Formals := New_List (
7811 Make_Parameter_Specification (Loc,
7812 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
7813 In_Present => True,
7814 Out_Present => True,
7815 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
7816
7817 -- F : Boolean := True
7818
7819 if Prim = Adjust_Case
7820 or else Prim = Finalize_Case
7821 then
7822 Append_To (Formals,
7823 Make_Parameter_Specification (Loc,
7824 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
7825 Parameter_Type =>
7826 New_Occurrence_Of (Standard_Boolean, Loc),
7827 Expression =>
7828 New_Occurrence_Of (Standard_True, Loc)));
7829 end if;
7830 end if;
7831
7832 Proc_Id :=
7833 Make_Defining_Identifier (Loc,
7834 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
7835
7836 -- Generate:
7837 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
7838 -- begin
7839 -- <stmts>
7840 -- exception -- Finalize and Adjust cases only
7841 -- raise Program_Error;
7842 -- end Deep_Initialize / Adjust / Finalize;
7843
7844 -- or
7845
7846 -- procedure Finalize_Address (V : System.Address) is
7847 -- begin
7848 -- <stmts>
7849 -- end Finalize_Address;
7850
7851 Discard_Node (
7852 Make_Subprogram_Body (Loc,
7853 Specification =>
7854 Make_Procedure_Specification (Loc,
7855 Defining_Unit_Name => Proc_Id,
7856 Parameter_Specifications => Formals),
7857
7858 Declarations => Empty_List,
7859
7860 Handled_Statement_Sequence =>
7861 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
7862
7863 return Proc_Id;
7864 end Make_Deep_Proc;
7865
7866 ---------------------------
7867 -- Make_Deep_Record_Body --
7868 ---------------------------
7869
7870 function Make_Deep_Record_Body
7871 (Prim : Final_Primitives;
7872 Typ : Entity_Id;
7873 Is_Local : Boolean := False) return List_Id
7874 is
7875 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
7876 -- Build the statements necessary to adjust a record type. The type may
7877 -- have discriminants and contain variant parts. Generate:
7878 --
7879 -- begin
7880 -- begin
7881 -- [Deep_]Adjust (V.Comp_1);
7882 -- exception
7883 -- when Id : others =>
7884 -- if not Raised then
7885 -- Raised := True;
7886 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7887 -- end if;
7888 -- end;
7889 -- . . .
7890 -- begin
7891 -- [Deep_]Adjust (V.Comp_N);
7892 -- exception
7893 -- when Id : others =>
7894 -- if not Raised then
7895 -- Raised := True;
7896 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7897 -- end if;
7898 -- end;
7899 --
7900 -- begin
7901 -- Deep_Adjust (V._parent, False); -- If applicable
7902 -- exception
7903 -- when Id : others =>
7904 -- if not Raised then
7905 -- Raised := True;
7906 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7907 -- end if;
7908 -- end;
7909 --
7910 -- if F then
7911 -- begin
7912 -- Adjust (V); -- If applicable
7913 -- exception
7914 -- when others =>
7915 -- if not Raised then
7916 -- Raised := True;
7917 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7918 -- end if;
7919 -- end;
7920 -- end if;
7921 --
7922 -- if Raised and then not Abort then
7923 -- Raise_From_Controlled_Operation (E);
7924 -- end if;
7925 -- end;
7926
7927 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
7928 -- Build the statements necessary to finalize a record type. The type
7929 -- may have discriminants and contain variant parts. Generate:
7930 --
7931 -- declare
7932 -- Abort : constant Boolean := Triggered_By_Abort;
7933 -- <or>
7934 -- Abort : constant Boolean := False; -- no abort
7935 -- E : Exception_Occurrence;
7936 -- Raised : Boolean := False;
7937 --
7938 -- begin
7939 -- if F then
7940 -- begin
7941 -- Finalize (V); -- If applicable
7942 -- exception
7943 -- when others =>
7944 -- if not Raised then
7945 -- Raised := True;
7946 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7947 -- end if;
7948 -- end;
7949 -- end if;
7950 --
7951 -- case Variant_1 is
7952 -- when Value_1 =>
7953 -- case State_Counter_N => -- If Is_Local is enabled
7954 -- when N => .
7955 -- goto LN; .
7956 -- ... .
7957 -- when 1 => .
7958 -- goto L1; .
7959 -- when others => .
7960 -- goto L0; .
7961 -- end case; .
7962 --
7963 -- <<LN>> -- If Is_Local is enabled
7964 -- begin
7965 -- [Deep_]Finalize (V.Comp_N);
7966 -- exception
7967 -- when others =>
7968 -- if not Raised then
7969 -- Raised := True;
7970 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7971 -- end if;
7972 -- end;
7973 -- . . .
7974 -- <<L1>>
7975 -- begin
7976 -- [Deep_]Finalize (V.Comp_1);
7977 -- exception
7978 -- when others =>
7979 -- if not Raised then
7980 -- Raised := True;
7981 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7982 -- end if;
7983 -- end;
7984 -- <<L0>>
7985 -- end case;
7986 --
7987 -- case State_Counter_1 => -- If Is_Local is enabled
7988 -- when M => .
7989 -- goto LM; .
7990 -- ...
7991 --
7992 -- begin
7993 -- Deep_Finalize (V._parent, False); -- If applicable
7994 -- exception
7995 -- when Id : others =>
7996 -- if not Raised then
7997 -- Raised := True;
7998 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7999 -- end if;
8000 -- end;
8001 --
8002 -- if Raised and then not Abort then
8003 -- Raise_From_Controlled_Operation (E);
8004 -- end if;
8005 -- end;
8006
8007 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
8008 -- Given a derived tagged type Typ, traverse all components, find field
8009 -- _parent and return its type.
8010
8011 procedure Preprocess_Components
8012 (Comps : Node_Id;
8013 Num_Comps : out Nat;
8014 Has_POC : out Boolean);
8015 -- Examine all components in component list Comps, count all controlled
8016 -- components and determine whether at least one of them is per-object
8017 -- constrained. Component _parent is always skipped.
8018
8019 -----------------------------
8020 -- Build_Adjust_Statements --
8021 -----------------------------
8022
8023 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
8024 Exceptions_OK : constant Boolean :=
8025 not Restriction_Active (No_Exception_Propagation);
8026 Loc : constant Source_Ptr := Sloc (Typ);
8027 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
8028
8029 Bod_Stmts : List_Id;
8030 Finalizer_Data : Finalization_Exception_Data;
8031 Finalizer_Decls : List_Id := No_List;
8032 Rec_Def : Node_Id;
8033 Var_Case : Node_Id;
8034
8035 function Process_Component_List_For_Adjust
8036 (Comps : Node_Id) return List_Id;
8037 -- Build all necessary adjust statements for a single component list
8038
8039 ---------------------------------------
8040 -- Process_Component_List_For_Adjust --
8041 ---------------------------------------
8042
8043 function Process_Component_List_For_Adjust
8044 (Comps : Node_Id) return List_Id
8045 is
8046 Stmts : constant List_Id := New_List;
8047 Decl : Node_Id;
8048 Decl_Id : Entity_Id;
8049 Decl_Typ : Entity_Id;
8050 Has_POC : Boolean;
8051 Num_Comps : Nat;
8052
8053 procedure Process_Component_For_Adjust (Decl : Node_Id);
8054 -- Process the declaration of a single controlled component
8055
8056 ----------------------------------
8057 -- Process_Component_For_Adjust --
8058 ----------------------------------
8059
8060 procedure Process_Component_For_Adjust (Decl : Node_Id) is
8061 Id : constant Entity_Id := Defining_Identifier (Decl);
8062 Typ : constant Entity_Id := Etype (Id);
8063 Adj_Stmt : Node_Id;
8064
8065 begin
8066 -- begin
8067 -- [Deep_]Adjust (V.Id);
8068
8069 -- exception
8070 -- when others =>
8071 -- if not Raised then
8072 -- Raised := True;
8073 -- Save_Occurrence (E, Get_Current_Excep.all.all);
8074 -- end if;
8075 -- end;
8076
8077 Adj_Stmt :=
8078 Make_Adjust_Call (
8079 Obj_Ref =>
8080 Make_Selected_Component (Loc,
8081 Prefix => Make_Identifier (Loc, Name_V),
8082 Selector_Name => Make_Identifier (Loc, Chars (Id))),
8083 Typ => Typ);
8084
8085 if Exceptions_OK then
8086 Adj_Stmt :=
8087 Make_Block_Statement (Loc,
8088 Handled_Statement_Sequence =>
8089 Make_Handled_Sequence_Of_Statements (Loc,
8090 Statements => New_List (Adj_Stmt),
8091 Exception_Handlers => New_List (
8092 Build_Exception_Handler (Finalizer_Data))));
8093 end if;
8094
8095 Append_To (Stmts, Adj_Stmt);
8096 end Process_Component_For_Adjust;
8097
8098 -- Start of processing for Process_Component_List_For_Adjust
8099
8100 begin
8101 -- Perform an initial check, determine the number of controlled
8102 -- components in the current list and whether at least one of them
8103 -- is per-object constrained.
8104
8105 Preprocess_Components (Comps, Num_Comps, Has_POC);
8106
8107 -- The processing in this routine is done in the following order:
8108 -- 1) Regular components
8109 -- 2) Per-object constrained components
8110 -- 3) Variant parts
8111
8112 if Num_Comps > 0 then
8113
8114 -- Process all regular components in order of declarations
8115
8116 Decl := First_Non_Pragma (Component_Items (Comps));
8117 while Present (Decl) loop
8118 Decl_Id := Defining_Identifier (Decl);
8119 Decl_Typ := Etype (Decl_Id);
8120
8121 -- Skip _parent as well as per-object constrained components
8122
8123 if Chars (Decl_Id) /= Name_uParent
8124 and then Needs_Finalization (Decl_Typ)
8125 then
8126 if Has_Access_Constraint (Decl_Id)
8127 and then No (Expression (Decl))
8128 then
8129 null;
8130 else
8131 Process_Component_For_Adjust (Decl);
8132 end if;
8133 end if;
8134
8135 Next_Non_Pragma (Decl);
8136 end loop;
8137
8138 -- Process all per-object constrained components in order of
8139 -- declarations.
8140
8141 if Has_POC then
8142 Decl := First_Non_Pragma (Component_Items (Comps));
8143 while Present (Decl) loop
8144 Decl_Id := Defining_Identifier (Decl);
8145 Decl_Typ := Etype (Decl_Id);
8146
8147 -- Skip _parent
8148
8149 if Chars (Decl_Id) /= Name_uParent
8150 and then Needs_Finalization (Decl_Typ)
8151 and then Has_Access_Constraint (Decl_Id)
8152 and then No (Expression (Decl))
8153 then
8154 Process_Component_For_Adjust (Decl);
8155 end if;
8156
8157 Next_Non_Pragma (Decl);
8158 end loop;
8159 end if;
8160 end if;
8161
8162 -- Process all variants, if any
8163
8164 Var_Case := Empty;
8165 if Present (Variant_Part (Comps)) then
8166 declare
8167 Var_Alts : constant List_Id := New_List;
8168 Var : Node_Id;
8169
8170 begin
8171 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
8172 while Present (Var) loop
8173
8174 -- Generate:
8175 -- when <discrete choices> =>
8176 -- <adjust statements>
8177
8178 Append_To (Var_Alts,
8179 Make_Case_Statement_Alternative (Loc,
8180 Discrete_Choices =>
8181 New_Copy_List (Discrete_Choices (Var)),
8182 Statements =>
8183 Process_Component_List_For_Adjust (
8184 Component_List (Var))));
8185
8186 Next_Non_Pragma (Var);
8187 end loop;
8188
8189 -- Generate:
8190 -- case V.<discriminant> is
8191 -- when <discrete choices 1> =>
8192 -- <adjust statements 1>
8193 -- ...
8194 -- when <discrete choices N> =>
8195 -- <adjust statements N>
8196 -- end case;
8197
8198 Var_Case :=
8199 Make_Case_Statement (Loc,
8200 Expression =>
8201 Make_Selected_Component (Loc,
8202 Prefix => Make_Identifier (Loc, Name_V),
8203 Selector_Name =>
8204 Make_Identifier (Loc,
8205 Chars => Chars (Name (Variant_Part (Comps))))),
8206 Alternatives => Var_Alts);
8207 end;
8208 end if;
8209
8210 -- Add the variant case statement to the list of statements
8211
8212 if Present (Var_Case) then
8213 Append_To (Stmts, Var_Case);
8214 end if;
8215
8216 -- If the component list did not have any controlled components
8217 -- nor variants, return null.
8218
8219 if Is_Empty_List (Stmts) then
8220 Append_To (Stmts, Make_Null_Statement (Loc));
8221 end if;
8222
8223 return Stmts;
8224 end Process_Component_List_For_Adjust;
8225
8226 -- Start of processing for Build_Adjust_Statements
8227
8228 begin
8229 Finalizer_Decls := New_List;
8230 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
8231
8232 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8233 Rec_Def := Record_Extension_Part (Typ_Def);
8234 else
8235 Rec_Def := Typ_Def;
8236 end if;
8237
8238 -- Create an adjust sequence for all record components
8239
8240 if Present (Component_List (Rec_Def)) then
8241 Bod_Stmts :=
8242 Process_Component_List_For_Adjust (Component_List (Rec_Def));
8243 end if;
8244
8245 -- A derived record type must adjust all inherited components. This
8246 -- action poses the following problem:
8247
8248 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
8249 -- begin
8250 -- Adjust (Obj);
8251 -- ...
8252
8253 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
8254 -- begin
8255 -- Deep_Adjust (Obj._parent);
8256 -- ...
8257 -- Adjust (Obj);
8258 -- ...
8259
8260 -- Adjusting the derived type will invoke Adjust of the parent and
8261 -- then that of the derived type. This is undesirable because both
8262 -- routines may modify shared components. Only the Adjust of the
8263 -- derived type should be invoked.
8264
8265 -- To prevent this double adjustment of shared components,
8266 -- Deep_Adjust uses a flag to control the invocation of Adjust:
8267
8268 -- procedure Deep_Adjust
8269 -- (Obj : in out Some_Type;
8270 -- Flag : Boolean := True)
8271 -- is
8272 -- begin
8273 -- if Flag then
8274 -- Adjust (Obj);
8275 -- end if;
8276 -- ...
8277
8278 -- When Deep_Adjust is invokes for field _parent, a value of False is
8279 -- provided for the flag:
8280
8281 -- Deep_Adjust (Obj._parent, False);
8282
8283 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8284 declare
8285 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8286 Adj_Stmt : Node_Id;
8287 Call : Node_Id;
8288
8289 begin
8290 if Needs_Finalization (Par_Typ) then
8291 Call :=
8292 Make_Adjust_Call
8293 (Obj_Ref =>
8294 Make_Selected_Component (Loc,
8295 Prefix => Make_Identifier (Loc, Name_V),
8296 Selector_Name =>
8297 Make_Identifier (Loc, Name_uParent)),
8298 Typ => Par_Typ,
8299 Skip_Self => True);
8300
8301 -- Generate:
8302 -- begin
8303 -- Deep_Adjust (V._parent, False);
8304
8305 -- exception
8306 -- when Id : others =>
8307 -- if not Raised then
8308 -- Raised := True;
8309 -- Save_Occurrence (E,
8310 -- Get_Current_Excep.all.all);
8311 -- end if;
8312 -- end;
8313
8314 if Present (Call) then
8315 Adj_Stmt := Call;
8316
8317 if Exceptions_OK then
8318 Adj_Stmt :=
8319 Make_Block_Statement (Loc,
8320 Handled_Statement_Sequence =>
8321 Make_Handled_Sequence_Of_Statements (Loc,
8322 Statements => New_List (Adj_Stmt),
8323 Exception_Handlers => New_List (
8324 Build_Exception_Handler (Finalizer_Data))));
8325 end if;
8326
8327 Prepend_To (Bod_Stmts, Adj_Stmt);
8328 end if;
8329 end if;
8330 end;
8331 end if;
8332
8333 -- Adjust the object. This action must be performed last after all
8334 -- components have been adjusted.
8335
8336 if Is_Controlled (Typ) then
8337 declare
8338 Adj_Stmt : Node_Id;
8339 Proc : Entity_Id;
8340
8341 begin
8342 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
8343
8344 -- Generate:
8345 -- if F then
8346 -- begin
8347 -- Adjust (V);
8348
8349 -- exception
8350 -- when others =>
8351 -- if not Raised then
8352 -- Raised := True;
8353 -- Save_Occurrence (E,
8354 -- Get_Current_Excep.all.all);
8355 -- end if;
8356 -- end;
8357 -- end if;
8358
8359 if Present (Proc) then
8360 Adj_Stmt :=
8361 Make_Procedure_Call_Statement (Loc,
8362 Name => New_Occurrence_Of (Proc, Loc),
8363 Parameter_Associations => New_List (
8364 Make_Identifier (Loc, Name_V)));
8365
8366 if Exceptions_OK then
8367 Adj_Stmt :=
8368 Make_Block_Statement (Loc,
8369 Handled_Statement_Sequence =>
8370 Make_Handled_Sequence_Of_Statements (Loc,
8371 Statements => New_List (Adj_Stmt),
8372 Exception_Handlers => New_List (
8373 Build_Exception_Handler
8374 (Finalizer_Data))));
8375 end if;
8376
8377 Append_To (Bod_Stmts,
8378 Make_If_Statement (Loc,
8379 Condition => Make_Identifier (Loc, Name_F),
8380 Then_Statements => New_List (Adj_Stmt)));
8381 end if;
8382 end;
8383 end if;
8384
8385 -- At this point either all adjustment statements have been generated
8386 -- or the type is not controlled.
8387
8388 if Is_Empty_List (Bod_Stmts) then
8389 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
8390
8391 return Bod_Stmts;
8392
8393 -- Generate:
8394 -- declare
8395 -- Abort : constant Boolean := Triggered_By_Abort;
8396 -- <or>
8397 -- Abort : constant Boolean := False; -- no abort
8398
8399 -- E : Exception_Occurrence;
8400 -- Raised : Boolean := False;
8401
8402 -- begin
8403 -- <adjust statements>
8404
8405 -- if Raised and then not Abort then
8406 -- Raise_From_Controlled_Operation (E);
8407 -- end if;
8408 -- end;
8409
8410 else
8411 if Exceptions_OK then
8412 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8413 end if;
8414
8415 return
8416 New_List (
8417 Make_Block_Statement (Loc,
8418 Declarations =>
8419 Finalizer_Decls,
8420 Handled_Statement_Sequence =>
8421 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8422 end if;
8423 end Build_Adjust_Statements;
8424
8425 -------------------------------
8426 -- Build_Finalize_Statements --
8427 -------------------------------
8428
8429 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
8430 Exceptions_OK : constant Boolean :=
8431 not Restriction_Active (No_Exception_Propagation);
8432 Loc : constant Source_Ptr := Sloc (Typ);
8433 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
8434
8435 Bod_Stmts : List_Id;
8436 Counter : Int := 0;
8437 Finalizer_Data : Finalization_Exception_Data;
8438 Finalizer_Decls : List_Id := No_List;
8439 Rec_Def : Node_Id;
8440 Var_Case : Node_Id;
8441
8442 function Process_Component_List_For_Finalize
8443 (Comps : Node_Id) return List_Id;
8444 -- Build all necessary finalization statements for a single component
8445 -- list. The statements may include a jump circuitry if flag Is_Local
8446 -- is enabled.
8447
8448 -----------------------------------------
8449 -- Process_Component_List_For_Finalize --
8450 -----------------------------------------
8451
8452 function Process_Component_List_For_Finalize
8453 (Comps : Node_Id) return List_Id
8454 is
8455 Alts : List_Id;
8456 Counter_Id : Entity_Id;
8457 Decl : Node_Id;
8458 Decl_Id : Entity_Id;
8459 Decl_Typ : Entity_Id;
8460 Decls : List_Id;
8461 Has_POC : Boolean;
8462 Jump_Block : Node_Id;
8463 Label : Node_Id;
8464 Label_Id : Entity_Id;
8465 Num_Comps : Nat;
8466 Stmts : List_Id;
8467
8468 procedure Process_Component_For_Finalize
8469 (Decl : Node_Id;
8470 Alts : List_Id;
8471 Decls : List_Id;
8472 Stmts : List_Id);
8473 -- Process the declaration of a single controlled component. If
8474 -- flag Is_Local is enabled, create the corresponding label and
8475 -- jump circuitry. Alts is the list of case alternatives, Decls
8476 -- is the top level declaration list where labels are declared
8477 -- and Stmts is the list of finalization actions.
8478
8479 ------------------------------------
8480 -- Process_Component_For_Finalize --
8481 ------------------------------------
8482
8483 procedure Process_Component_For_Finalize
8484 (Decl : Node_Id;
8485 Alts : List_Id;
8486 Decls : List_Id;
8487 Stmts : List_Id)
8488 is
8489 Id : constant Entity_Id := Defining_Identifier (Decl);
8490 Typ : constant Entity_Id := Etype (Id);
8491 Fin_Stmt : Node_Id;
8492
8493 begin
8494 if Is_Local then
8495 declare
8496 Label : Node_Id;
8497 Label_Id : Entity_Id;
8498
8499 begin
8500 -- Generate:
8501 -- LN : label;
8502
8503 Label_Id :=
8504 Make_Identifier (Loc,
8505 Chars => New_External_Name ('L', Num_Comps));
8506 Set_Entity (Label_Id,
8507 Make_Defining_Identifier (Loc, Chars (Label_Id)));
8508 Label := Make_Label (Loc, Label_Id);
8509
8510 Append_To (Decls,
8511 Make_Implicit_Label_Declaration (Loc,
8512 Defining_Identifier => Entity (Label_Id),
8513 Label_Construct => Label));
8514
8515 -- Generate:
8516 -- when N =>
8517 -- goto LN;
8518
8519 Append_To (Alts,
8520 Make_Case_Statement_Alternative (Loc,
8521 Discrete_Choices => New_List (
8522 Make_Integer_Literal (Loc, Num_Comps)),
8523
8524 Statements => New_List (
8525 Make_Goto_Statement (Loc,
8526 Name =>
8527 New_Occurrence_Of (Entity (Label_Id), Loc)))));
8528
8529 -- Generate:
8530 -- <<LN>>
8531
8532 Append_To (Stmts, Label);
8533
8534 -- Decrease the number of components to be processed.
8535 -- This action yields a new Label_Id in future calls.
8536
8537 Num_Comps := Num_Comps - 1;
8538 end;
8539 end if;
8540
8541 -- Generate:
8542 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
8543
8544 -- begin -- Exception handlers allowed
8545 -- [Deep_]Finalize (V.Id);
8546 -- exception
8547 -- when others =>
8548 -- if not Raised then
8549 -- Raised := True;
8550 -- Save_Occurrence (E,
8551 -- Get_Current_Excep.all.all);
8552 -- end if;
8553 -- end;
8554
8555 Fin_Stmt :=
8556 Make_Final_Call
8557 (Obj_Ref =>
8558 Make_Selected_Component (Loc,
8559 Prefix => Make_Identifier (Loc, Name_V),
8560 Selector_Name => Make_Identifier (Loc, Chars (Id))),
8561 Typ => Typ);
8562
8563 if not Restriction_Active (No_Exception_Propagation) then
8564 Fin_Stmt :=
8565 Make_Block_Statement (Loc,
8566 Handled_Statement_Sequence =>
8567 Make_Handled_Sequence_Of_Statements (Loc,
8568 Statements => New_List (Fin_Stmt),
8569 Exception_Handlers => New_List (
8570 Build_Exception_Handler (Finalizer_Data))));
8571 end if;
8572
8573 Append_To (Stmts, Fin_Stmt);
8574 end Process_Component_For_Finalize;
8575
8576 -- Start of processing for Process_Component_List_For_Finalize
8577
8578 begin
8579 -- Perform an initial check, look for controlled and per-object
8580 -- constrained components.
8581
8582 Preprocess_Components (Comps, Num_Comps, Has_POC);
8583
8584 -- Create a state counter to service the current component list.
8585 -- This step is performed before the variants are inspected in
8586 -- order to generate the same state counter names as those from
8587 -- Build_Initialize_Statements.
8588
8589 if Num_Comps > 0 and then Is_Local then
8590 Counter := Counter + 1;
8591
8592 Counter_Id :=
8593 Make_Defining_Identifier (Loc,
8594 Chars => New_External_Name ('C', Counter));
8595 end if;
8596
8597 -- Process the component in the following order:
8598 -- 1) Variants
8599 -- 2) Per-object constrained components
8600 -- 3) Regular components
8601
8602 -- Start with the variant parts
8603
8604 Var_Case := Empty;
8605 if Present (Variant_Part (Comps)) then
8606 declare
8607 Var_Alts : constant List_Id := New_List;
8608 Var : Node_Id;
8609
8610 begin
8611 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
8612 while Present (Var) loop
8613
8614 -- Generate:
8615 -- when <discrete choices> =>
8616 -- <finalize statements>
8617
8618 Append_To (Var_Alts,
8619 Make_Case_Statement_Alternative (Loc,
8620 Discrete_Choices =>
8621 New_Copy_List (Discrete_Choices (Var)),
8622 Statements =>
8623 Process_Component_List_For_Finalize (
8624 Component_List (Var))));
8625
8626 Next_Non_Pragma (Var);
8627 end loop;
8628
8629 -- Generate:
8630 -- case V.<discriminant> is
8631 -- when <discrete choices 1> =>
8632 -- <finalize statements 1>
8633 -- ...
8634 -- when <discrete choices N> =>
8635 -- <finalize statements N>
8636 -- end case;
8637
8638 Var_Case :=
8639 Make_Case_Statement (Loc,
8640 Expression =>
8641 Make_Selected_Component (Loc,
8642 Prefix => Make_Identifier (Loc, Name_V),
8643 Selector_Name =>
8644 Make_Identifier (Loc,
8645 Chars => Chars (Name (Variant_Part (Comps))))),
8646 Alternatives => Var_Alts);
8647 end;
8648 end if;
8649
8650 -- The current component list does not have a single controlled
8651 -- component, however it may contain variants. Return the case
8652 -- statement for the variants or nothing.
8653
8654 if Num_Comps = 0 then
8655 if Present (Var_Case) then
8656 return New_List (Var_Case);
8657 else
8658 return New_List (Make_Null_Statement (Loc));
8659 end if;
8660 end if;
8661
8662 -- Prepare all lists
8663
8664 Alts := New_List;
8665 Decls := New_List;
8666 Stmts := New_List;
8667
8668 -- Process all per-object constrained components in reverse order
8669
8670 if Has_POC then
8671 Decl := Last_Non_Pragma (Component_Items (Comps));
8672 while Present (Decl) loop
8673 Decl_Id := Defining_Identifier (Decl);
8674 Decl_Typ := Etype (Decl_Id);
8675
8676 -- Skip _parent
8677
8678 if Chars (Decl_Id) /= Name_uParent
8679 and then Needs_Finalization (Decl_Typ)
8680 and then Has_Access_Constraint (Decl_Id)
8681 and then No (Expression (Decl))
8682 then
8683 Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
8684 end if;
8685
8686 Prev_Non_Pragma (Decl);
8687 end loop;
8688 end if;
8689
8690 -- Process the rest of the components in reverse order
8691
8692 Decl := Last_Non_Pragma (Component_Items (Comps));
8693 while Present (Decl) loop
8694 Decl_Id := Defining_Identifier (Decl);
8695 Decl_Typ := Etype (Decl_Id);
8696
8697 -- Skip _parent
8698
8699 if Chars (Decl_Id) /= Name_uParent
8700 and then Needs_Finalization (Decl_Typ)
8701 then
8702 -- Skip per-object constrained components since they were
8703 -- handled in the above step.
8704
8705 if Has_Access_Constraint (Decl_Id)
8706 and then No (Expression (Decl))
8707 then
8708 null;
8709 else
8710 Process_Component_For_Finalize (Decl, Alts, Decls, Stmts);
8711 end if;
8712 end if;
8713
8714 Prev_Non_Pragma (Decl);
8715 end loop;
8716
8717 -- Generate:
8718 -- declare
8719 -- LN : label; -- If Is_Local is enabled
8720 -- ... .
8721 -- L0 : label; .
8722
8723 -- begin .
8724 -- case CounterX is .
8725 -- when N => .
8726 -- goto LN; .
8727 -- ... .
8728 -- when 1 => .
8729 -- goto L1; .
8730 -- when others => .
8731 -- goto L0; .
8732 -- end case; .
8733
8734 -- <<LN>> -- If Is_Local is enabled
8735 -- begin
8736 -- [Deep_]Finalize (V.CompY);
8737 -- exception
8738 -- when Id : others =>
8739 -- if not Raised then
8740 -- Raised := True;
8741 -- Save_Occurrence (E,
8742 -- Get_Current_Excep.all.all);
8743 -- end if;
8744 -- end;
8745 -- ...
8746 -- <<L0>> -- If Is_Local is enabled
8747 -- end;
8748
8749 if Is_Local then
8750
8751 -- Add the declaration of default jump location L0, its
8752 -- corresponding alternative and its place in the statements.
8753
8754 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
8755 Set_Entity (Label_Id,
8756 Make_Defining_Identifier (Loc, Chars (Label_Id)));
8757 Label := Make_Label (Loc, Label_Id);
8758
8759 Append_To (Decls, -- declaration
8760 Make_Implicit_Label_Declaration (Loc,
8761 Defining_Identifier => Entity (Label_Id),
8762 Label_Construct => Label));
8763
8764 Append_To (Alts, -- alternative
8765 Make_Case_Statement_Alternative (Loc,
8766 Discrete_Choices => New_List (
8767 Make_Others_Choice (Loc)),
8768
8769 Statements => New_List (
8770 Make_Goto_Statement (Loc,
8771 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
8772
8773 Append_To (Stmts, Label); -- statement
8774
8775 -- Create the jump block
8776
8777 Prepend_To (Stmts,
8778 Make_Case_Statement (Loc,
8779 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
8780 Alternatives => Alts));
8781 end if;
8782
8783 Jump_Block :=
8784 Make_Block_Statement (Loc,
8785 Declarations => Decls,
8786 Handled_Statement_Sequence =>
8787 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
8788
8789 if Present (Var_Case) then
8790 return New_List (Var_Case, Jump_Block);
8791 else
8792 return New_List (Jump_Block);
8793 end if;
8794 end Process_Component_List_For_Finalize;
8795
8796 -- Start of processing for Build_Finalize_Statements
8797
8798 begin
8799 Finalizer_Decls := New_List;
8800 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
8801
8802 if Nkind (Typ_Def) = N_Derived_Type_Definition then
8803 Rec_Def := Record_Extension_Part (Typ_Def);
8804 else
8805 Rec_Def := Typ_Def;
8806 end if;
8807
8808 -- Create a finalization sequence for all record components
8809
8810 if Present (Component_List (Rec_Def)) then
8811 Bod_Stmts :=
8812 Process_Component_List_For_Finalize (Component_List (Rec_Def));
8813 end if;
8814
8815 -- A derived record type must finalize all inherited components. This
8816 -- action poses the following problem:
8817
8818 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
8819 -- begin
8820 -- Finalize (Obj);
8821 -- ...
8822
8823 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
8824 -- begin
8825 -- Deep_Finalize (Obj._parent);
8826 -- ...
8827 -- Finalize (Obj);
8828 -- ...
8829
8830 -- Finalizing the derived type will invoke Finalize of the parent and
8831 -- then that of the derived type. This is undesirable because both
8832 -- routines may modify shared components. Only the Finalize of the
8833 -- derived type should be invoked.
8834
8835 -- To prevent this double adjustment of shared components,
8836 -- Deep_Finalize uses a flag to control the invocation of Finalize:
8837
8838 -- procedure Deep_Finalize
8839 -- (Obj : in out Some_Type;
8840 -- Flag : Boolean := True)
8841 -- is
8842 -- begin
8843 -- if Flag then
8844 -- Finalize (Obj);
8845 -- end if;
8846 -- ...
8847
8848 -- When Deep_Finalize is invoked for field _parent, a value of False
8849 -- is provided for the flag:
8850
8851 -- Deep_Finalize (Obj._parent, False);
8852
8853 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8854 declare
8855 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8856 Call : Node_Id;
8857 Fin_Stmt : Node_Id;
8858
8859 begin
8860 if Needs_Finalization (Par_Typ) then
8861 Call :=
8862 Make_Final_Call
8863 (Obj_Ref =>
8864 Make_Selected_Component (Loc,
8865 Prefix => Make_Identifier (Loc, Name_V),
8866 Selector_Name =>
8867 Make_Identifier (Loc, Name_uParent)),
8868 Typ => Par_Typ,
8869 Skip_Self => True);
8870
8871 -- Generate:
8872 -- begin
8873 -- Deep_Finalize (V._parent, False);
8874
8875 -- exception
8876 -- when Id : others =>
8877 -- if not Raised then
8878 -- Raised := True;
8879 -- Save_Occurrence (E,
8880 -- Get_Current_Excep.all.all);
8881 -- end if;
8882 -- end;
8883
8884 if Present (Call) then
8885 Fin_Stmt := Call;
8886
8887 if Exceptions_OK then
8888 Fin_Stmt :=
8889 Make_Block_Statement (Loc,
8890 Handled_Statement_Sequence =>
8891 Make_Handled_Sequence_Of_Statements (Loc,
8892 Statements => New_List (Fin_Stmt),
8893 Exception_Handlers => New_List (
8894 Build_Exception_Handler
8895 (Finalizer_Data))));
8896 end if;
8897
8898 Append_To (Bod_Stmts, Fin_Stmt);
8899 end if;
8900 end if;
8901 end;
8902 end if;
8903
8904 -- Finalize the object. This action must be performed first before
8905 -- all components have been finalized.
8906
8907 if Is_Controlled (Typ) and then not Is_Local then
8908 declare
8909 Fin_Stmt : Node_Id;
8910 Proc : Entity_Id;
8911
8912 begin
8913 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
8914
8915 -- Generate:
8916 -- if F then
8917 -- begin
8918 -- Finalize (V);
8919
8920 -- exception
8921 -- when others =>
8922 -- if not Raised then
8923 -- Raised := True;
8924 -- Save_Occurrence (E,
8925 -- Get_Current_Excep.all.all);
8926 -- end if;
8927 -- end;
8928 -- end if;
8929
8930 if Present (Proc) then
8931 Fin_Stmt :=
8932 Make_Procedure_Call_Statement (Loc,
8933 Name => New_Occurrence_Of (Proc, Loc),
8934 Parameter_Associations => New_List (
8935 Make_Identifier (Loc, Name_V)));
8936
8937 if Exceptions_OK then
8938 Fin_Stmt :=
8939 Make_Block_Statement (Loc,
8940 Handled_Statement_Sequence =>
8941 Make_Handled_Sequence_Of_Statements (Loc,
8942 Statements => New_List (Fin_Stmt),
8943 Exception_Handlers => New_List (
8944 Build_Exception_Handler
8945 (Finalizer_Data))));
8946 end if;
8947
8948 Prepend_To (Bod_Stmts,
8949 Make_If_Statement (Loc,
8950 Condition => Make_Identifier (Loc, Name_F),
8951 Then_Statements => New_List (Fin_Stmt)));
8952 end if;
8953 end;
8954 end if;
8955
8956 -- At this point either all finalization statements have been
8957 -- generated or the type is not controlled.
8958
8959 if No (Bod_Stmts) then
8960 return New_List (Make_Null_Statement (Loc));
8961
8962 -- Generate:
8963 -- declare
8964 -- Abort : constant Boolean := Triggered_By_Abort;
8965 -- <or>
8966 -- Abort : constant Boolean := False; -- no abort
8967
8968 -- E : Exception_Occurrence;
8969 -- Raised : Boolean := False;
8970
8971 -- begin
8972 -- <finalize statements>
8973
8974 -- if Raised and then not Abort then
8975 -- Raise_From_Controlled_Operation (E);
8976 -- end if;
8977 -- end;
8978
8979 else
8980 if Exceptions_OK then
8981 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8982 end if;
8983
8984 return
8985 New_List (
8986 Make_Block_Statement (Loc,
8987 Declarations =>
8988 Finalizer_Decls,
8989 Handled_Statement_Sequence =>
8990 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8991 end if;
8992 end Build_Finalize_Statements;
8993
8994 -----------------------
8995 -- Parent_Field_Type --
8996 -----------------------
8997
8998 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
8999 Field : Entity_Id;
9000
9001 begin
9002 Field := First_Entity (Typ);
9003 while Present (Field) loop
9004 if Chars (Field) = Name_uParent then
9005 return Etype (Field);
9006 end if;
9007
9008 Next_Entity (Field);
9009 end loop;
9010
9011 -- A derived tagged type should always have a parent field
9012
9013 raise Program_Error;
9014 end Parent_Field_Type;
9015
9016 ---------------------------
9017 -- Preprocess_Components --
9018 ---------------------------
9019
9020 procedure Preprocess_Components
9021 (Comps : Node_Id;
9022 Num_Comps : out Nat;
9023 Has_POC : out Boolean)
9024 is
9025 Decl : Node_Id;
9026 Id : Entity_Id;
9027 Typ : Entity_Id;
9028
9029 begin
9030 Num_Comps := 0;
9031 Has_POC := False;
9032
9033 Decl := First_Non_Pragma (Component_Items (Comps));
9034 while Present (Decl) loop
9035 Id := Defining_Identifier (Decl);
9036 Typ := Etype (Id);
9037
9038 -- Skip field _parent
9039
9040 if Chars (Id) /= Name_uParent
9041 and then Needs_Finalization (Typ)
9042 then
9043 Num_Comps := Num_Comps + 1;
9044
9045 if Has_Access_Constraint (Id)
9046 and then No (Expression (Decl))
9047 then
9048 Has_POC := True;
9049 end if;
9050 end if;
9051
9052 Next_Non_Pragma (Decl);
9053 end loop;
9054 end Preprocess_Components;
9055
9056 -- Start of processing for Make_Deep_Record_Body
9057
9058 begin
9059 case Prim is
9060 when Address_Case =>
9061 return Make_Finalize_Address_Stmts (Typ);
9062
9063 when Adjust_Case =>
9064 return Build_Adjust_Statements (Typ);
9065
9066 when Finalize_Case =>
9067 return Build_Finalize_Statements (Typ);
9068
9069 when Initialize_Case =>
9070 declare
9071 Loc : constant Source_Ptr := Sloc (Typ);
9072
9073 begin
9074 if Is_Controlled (Typ) then
9075 return New_List (
9076 Make_Procedure_Call_Statement (Loc,
9077 Name =>
9078 New_Occurrence_Of
9079 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
9080 Parameter_Associations => New_List (
9081 Make_Identifier (Loc, Name_V))));
9082 else
9083 return Empty_List;
9084 end if;
9085 end;
9086 end case;
9087 end Make_Deep_Record_Body;
9088
9089 ----------------------
9090 -- Make_Final_Call --
9091 ----------------------
9092
9093 function Make_Final_Call
9094 (Obj_Ref : Node_Id;
9095 Typ : Entity_Id;
9096 Skip_Self : Boolean := False) return Node_Id
9097 is
9098 Loc : constant Source_Ptr := Sloc (Obj_Ref);
9099 Atyp : Entity_Id;
9100 Fin_Id : Entity_Id := Empty;
9101 Ref : Node_Id;
9102 Utyp : Entity_Id;
9103
9104 begin
9105 -- Recover the proper type which contains [Deep_]Finalize
9106
9107 if Is_Class_Wide_Type (Typ) then
9108 Utyp := Root_Type (Typ);
9109 Atyp := Utyp;
9110 Ref := Obj_Ref;
9111
9112 elsif Is_Concurrent_Type (Typ) then
9113 Utyp := Corresponding_Record_Type (Typ);
9114 Atyp := Empty;
9115 Ref := Convert_Concurrent (Obj_Ref, Typ);
9116
9117 elsif Is_Private_Type (Typ)
9118 and then Present (Full_View (Typ))
9119 and then Is_Concurrent_Type (Full_View (Typ))
9120 then
9121 Utyp := Corresponding_Record_Type (Full_View (Typ));
9122 Atyp := Typ;
9123 Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ));
9124
9125 else
9126 Utyp := Typ;
9127 Atyp := Typ;
9128 Ref := Obj_Ref;
9129 end if;
9130
9131 Utyp := Underlying_Type (Base_Type (Utyp));
9132 Set_Assignment_OK (Ref);
9133
9134 -- Deal with untagged derivation of private views. If the parent type
9135 -- is a protected type, Deep_Finalize is found on the corresponding
9136 -- record of the ancestor.
9137
9138 if Is_Untagged_Derivation (Typ) then
9139 if Is_Protected_Type (Typ) then
9140 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
9141 else
9142 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
9143
9144 if Is_Protected_Type (Utyp) then
9145 Utyp := Corresponding_Record_Type (Utyp);
9146 end if;
9147 end if;
9148
9149 Ref := Unchecked_Convert_To (Utyp, Ref);
9150 Set_Assignment_OK (Ref);
9151 end if;
9152
9153 -- Deal with derived private types which do not inherit primitives from
9154 -- their parents. In this case, [Deep_]Finalize can be found in the full
9155 -- view of the parent type.
9156
9157 if Is_Tagged_Type (Utyp)
9158 and then Is_Derived_Type (Utyp)
9159 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
9160 and then Is_Private_Type (Etype (Utyp))
9161 and then Present (Full_View (Etype (Utyp)))
9162 then
9163 Utyp := Full_View (Etype (Utyp));
9164 Ref := Unchecked_Convert_To (Utyp, Ref);
9165 Set_Assignment_OK (Ref);
9166 end if;
9167
9168 -- When dealing with the completion of a private type, use the base type
9169 -- instead.
9170
9171 if Utyp /= Base_Type (Utyp) then
9172 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
9173
9174 Utyp := Base_Type (Utyp);
9175 Ref := Unchecked_Convert_To (Utyp, Ref);
9176 Set_Assignment_OK (Ref);
9177 end if;
9178
9179 if Skip_Self then
9180 if Has_Controlled_Component (Utyp) then
9181 if Is_Tagged_Type (Utyp) then
9182 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9183 else
9184 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
9185 end if;
9186 end if;
9187
9188 -- Class-wide types, interfaces and types with controlled components
9189
9190 elsif Is_Class_Wide_Type (Typ)
9191 or else Is_Interface (Typ)
9192 or else Has_Controlled_Component (Utyp)
9193 then
9194 if Is_Tagged_Type (Utyp) then
9195 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9196 else
9197 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
9198 end if;
9199
9200 -- Derivations from [Limited_]Controlled
9201
9202 elsif Is_Controlled (Utyp) then
9203 if Has_Controlled_Component (Utyp) then
9204 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9205 else
9206 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
9207 end if;
9208
9209 -- Tagged types
9210
9211 elsif Is_Tagged_Type (Utyp) then
9212 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
9213
9214 else
9215 raise Program_Error;
9216 end if;
9217
9218 if Present (Fin_Id) then
9219
9220 -- When finalizing a class-wide object, do not convert to the root
9221 -- type in order to produce a dispatching call.
9222
9223 if Is_Class_Wide_Type (Typ) then
9224 null;
9225
9226 -- Ensure that a finalization routine is at least decorated in order
9227 -- to inspect the object parameter.
9228
9229 elsif Analyzed (Fin_Id)
9230 or else Ekind (Fin_Id) = E_Procedure
9231 then
9232 -- In certain cases, such as the creation of Stream_Read, the
9233 -- visible entity of the type is its full view. Since Stream_Read
9234 -- will have to create an object of type Typ, the local object
9235 -- will be finalzed by the scope finalizer generated later on. The
9236 -- object parameter of Deep_Finalize will always use the private
9237 -- view of the type. To avoid such a clash between a private and a
9238 -- full view, perform an unchecked conversion of the object
9239 -- reference to the private view.
9240
9241 declare
9242 Formal_Typ : constant Entity_Id :=
9243 Etype (First_Formal (Fin_Id));
9244 begin
9245 if Is_Private_Type (Formal_Typ)
9246 and then Present (Full_View (Formal_Typ))
9247 and then Full_View (Formal_Typ) = Utyp
9248 then
9249 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
9250 end if;
9251 end;
9252
9253 Ref := Convert_View (Fin_Id, Ref);
9254 end if;
9255
9256 return
9257 Make_Call (Loc,
9258 Proc_Id => Fin_Id,
9259 Param => New_Copy_Tree (Ref),
9260 Skip_Self => Skip_Self);
9261 else
9262 return Empty;
9263 end if;
9264 end Make_Final_Call;
9265
9266 --------------------------------
9267 -- Make_Finalize_Address_Body --
9268 --------------------------------
9269
9270 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
9271 Is_Task : constant Boolean :=
9272 Ekind (Typ) = E_Record_Type
9273 and then Is_Concurrent_Record_Type (Typ)
9274 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
9275 E_Task_Type;
9276 Loc : constant Source_Ptr := Sloc (Typ);
9277 Proc_Id : Entity_Id;
9278 Stmts : List_Id;
9279
9280 begin
9281 -- The corresponding records of task types are not controlled by design.
9282 -- For the sake of completeness, create an empty Finalize_Address to be
9283 -- used in task class-wide allocations.
9284
9285 if Is_Task then
9286 null;
9287
9288 -- Nothing to do if the type is not controlled or it already has a
9289 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
9290 -- come from source. These are usually generated for completeness and
9291 -- do not need the Finalize_Address primitive.
9292
9293 elsif not Needs_Finalization (Typ)
9294 or else Present (TSS (Typ, TSS_Finalize_Address))
9295 or else
9296 (Is_Class_Wide_Type (Typ)
9297 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
9298 and then not Comes_From_Source (Root_Type (Typ)))
9299 then
9300 return;
9301 end if;
9302
9303 Proc_Id :=
9304 Make_Defining_Identifier (Loc,
9305 Make_TSS_Name (Typ, TSS_Finalize_Address));
9306
9307 -- Generate:
9308
9309 -- procedure <Typ>FD (V : System.Address) is
9310 -- begin
9311 -- null; -- for tasks
9312
9313 -- declare -- for all other types
9314 -- type Pnn is access all Typ;
9315 -- for Pnn'Storage_Size use 0;
9316 -- begin
9317 -- [Deep_]Finalize (Pnn (V).all);
9318 -- end;
9319 -- end TypFD;
9320
9321 if Is_Task then
9322 Stmts := New_List (Make_Null_Statement (Loc));
9323 else
9324 Stmts := Make_Finalize_Address_Stmts (Typ);
9325 end if;
9326
9327 Discard_Node (
9328 Make_Subprogram_Body (Loc,
9329 Specification =>
9330 Make_Procedure_Specification (Loc,
9331 Defining_Unit_Name => Proc_Id,
9332
9333 Parameter_Specifications => New_List (
9334 Make_Parameter_Specification (Loc,
9335 Defining_Identifier =>
9336 Make_Defining_Identifier (Loc, Name_V),
9337 Parameter_Type =>
9338 New_Occurrence_Of (RTE (RE_Address), Loc)))),
9339
9340 Declarations => No_List,
9341
9342 Handled_Statement_Sequence =>
9343 Make_Handled_Sequence_Of_Statements (Loc,
9344 Statements => Stmts)));
9345
9346 Set_TSS (Typ, Proc_Id);
9347 end Make_Finalize_Address_Body;
9348
9349 ---------------------------------
9350 -- Make_Finalize_Address_Stmts --
9351 ---------------------------------
9352
9353 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
9354 Loc : constant Source_Ptr := Sloc (Typ);
9355 Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P');
9356 Decls : List_Id;
9357 Desg_Typ : Entity_Id;
9358 Obj_Expr : Node_Id;
9359
9360 begin
9361 if Is_Array_Type (Typ) then
9362 if Is_Constrained (First_Subtype (Typ)) then
9363 Desg_Typ := First_Subtype (Typ);
9364 else
9365 Desg_Typ := Base_Type (Typ);
9366 end if;
9367
9368 -- Class-wide types of constrained root types
9369
9370 elsif Is_Class_Wide_Type (Typ)
9371 and then Has_Discriminants (Root_Type (Typ))
9372 and then not
9373 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
9374 then
9375 declare
9376 Parent_Typ : Entity_Id;
9377
9378 begin
9379 -- Climb the parent type chain looking for a non-constrained type
9380
9381 Parent_Typ := Root_Type (Typ);
9382 while Parent_Typ /= Etype (Parent_Typ)
9383 and then Has_Discriminants (Parent_Typ)
9384 and then not
9385 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
9386 loop
9387 Parent_Typ := Etype (Parent_Typ);
9388 end loop;
9389
9390 -- Handle views created for tagged types with unknown
9391 -- discriminants.
9392
9393 if Is_Underlying_Record_View (Parent_Typ) then
9394 Parent_Typ := Underlying_Record_View (Parent_Typ);
9395 end if;
9396
9397 Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
9398 end;
9399
9400 -- General case
9401
9402 else
9403 Desg_Typ := Typ;
9404 end if;
9405
9406 -- Generate:
9407 -- type Ptr_Typ is access all Typ;
9408 -- for Ptr_Typ'Storage_Size use 0;
9409
9410 Decls := New_List (
9411 Make_Full_Type_Declaration (Loc,
9412 Defining_Identifier => Ptr_Typ,
9413 Type_Definition =>
9414 Make_Access_To_Object_Definition (Loc,
9415 All_Present => True,
9416 Subtype_Indication => New_Occurrence_Of (Desg_Typ, Loc))),
9417
9418 Make_Attribute_Definition_Clause (Loc,
9419 Name => New_Occurrence_Of (Ptr_Typ, Loc),
9420 Chars => Name_Storage_Size,
9421 Expression => Make_Integer_Literal (Loc, 0)));
9422
9423 Obj_Expr := Make_Identifier (Loc, Name_V);
9424
9425 -- Unconstrained arrays require special processing in order to retrieve
9426 -- the elements. To achieve this, we have to skip the dope vector which
9427 -- lays in front of the elements and then use a thin pointer to perform
9428 -- the address-to-access conversion.
9429
9430 if Is_Array_Type (Typ)
9431 and then not Is_Constrained (First_Subtype (Typ))
9432 then
9433 declare
9434 Dope_Id : Entity_Id;
9435
9436 begin
9437 -- Ensure that Ptr_Typ a thin pointer, generate:
9438 -- for Ptr_Typ'Size use System.Address'Size;
9439
9440 Append_To (Decls,
9441 Make_Attribute_Definition_Clause (Loc,
9442 Name => New_Occurrence_Of (Ptr_Typ, Loc),
9443 Chars => Name_Size,
9444 Expression =>
9445 Make_Integer_Literal (Loc, System_Address_Size)));
9446
9447 -- Generate:
9448 -- Dnn : constant Storage_Offset :=
9449 -- Desg_Typ'Descriptor_Size / Storage_Unit;
9450
9451 Dope_Id := Make_Temporary (Loc, 'D');
9452
9453 Append_To (Decls,
9454 Make_Object_Declaration (Loc,
9455 Defining_Identifier => Dope_Id,
9456 Constant_Present => True,
9457 Object_Definition =>
9458 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9459 Expression =>
9460 Make_Op_Divide (Loc,
9461 Left_Opnd =>
9462 Make_Attribute_Reference (Loc,
9463 Prefix => New_Occurrence_Of (Desg_Typ, Loc),
9464 Attribute_Name => Name_Descriptor_Size),
9465 Right_Opnd =>
9466 Make_Integer_Literal (Loc, System_Storage_Unit))));
9467
9468 -- Shift the address from the start of the dope vector to the
9469 -- start of the elements:
9470 --
9471 -- V + Dnn
9472 --
9473 -- Note that this is done through a wrapper routine since RTSfind
9474 -- cannot retrieve operations with string names of the form "+".
9475
9476 Obj_Expr :=
9477 Make_Function_Call (Loc,
9478 Name =>
9479 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
9480 Parameter_Associations => New_List (
9481 Obj_Expr,
9482 New_Occurrence_Of (Dope_Id, Loc)));
9483 end;
9484 end if;
9485
9486 -- Create the block and the finalization call
9487
9488 return New_List (
9489 Make_Block_Statement (Loc,
9490 Declarations => Decls,
9491
9492 Handled_Statement_Sequence =>
9493 Make_Handled_Sequence_Of_Statements (Loc,
9494 Statements => New_List (
9495 Make_Final_Call (
9496 Obj_Ref =>
9497 Make_Explicit_Dereference (Loc,
9498 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
9499 Typ => Desg_Typ)))));
9500 end Make_Finalize_Address_Stmts;
9501
9502 -------------------------------------
9503 -- Make_Handler_For_Ctrl_Operation --
9504 -------------------------------------
9505
9506 -- Generate:
9507
9508 -- when E : others =>
9509 -- Raise_From_Controlled_Operation (E);
9510
9511 -- or:
9512
9513 -- when others =>
9514 -- raise Program_Error [finalize raised exception];
9515
9516 -- depending on whether Raise_From_Controlled_Operation is available
9517
9518 function Make_Handler_For_Ctrl_Operation
9519 (Loc : Source_Ptr) return Node_Id
9520 is
9521 E_Occ : Entity_Id;
9522 -- Choice parameter (for the first case above)
9523
9524 Raise_Node : Node_Id;
9525 -- Procedure call or raise statement
9526
9527 begin
9528 -- Standard run-time: add choice parameter E and pass it to
9529 -- Raise_From_Controlled_Operation so that the original exception
9530 -- name and message can be recorded in the exception message for
9531 -- Program_Error.
9532
9533 if RTE_Available (RE_Raise_From_Controlled_Operation) then
9534 E_Occ := Make_Defining_Identifier (Loc, Name_E);
9535 Raise_Node :=
9536 Make_Procedure_Call_Statement (Loc,
9537 Name =>
9538 New_Occurrence_Of
9539 (RTE (RE_Raise_From_Controlled_Operation), Loc),
9540 Parameter_Associations => New_List (
9541 New_Occurrence_Of (E_Occ, Loc)));
9542
9543 -- Restricted run-time: exception messages are not supported
9544
9545 else
9546 E_Occ := Empty;
9547 Raise_Node :=
9548 Make_Raise_Program_Error (Loc,
9549 Reason => PE_Finalize_Raised_Exception);
9550 end if;
9551
9552 return
9553 Make_Implicit_Exception_Handler (Loc,
9554 Exception_Choices => New_List (Make_Others_Choice (Loc)),
9555 Choice_Parameter => E_Occ,
9556 Statements => New_List (Raise_Node));
9557 end Make_Handler_For_Ctrl_Operation;
9558
9559 --------------------
9560 -- Make_Init_Call --
9561 --------------------
9562
9563 function Make_Init_Call
9564 (Obj_Ref : Node_Id;
9565 Typ : Entity_Id) return Node_Id
9566 is
9567 Loc : constant Source_Ptr := Sloc (Obj_Ref);
9568 Is_Conc : Boolean;
9569 Proc : Entity_Id;
9570 Ref : Node_Id;
9571 Utyp : Entity_Id;
9572
9573 begin
9574 -- Deal with the type and object reference. Depending on the context, an
9575 -- object reference may need several conversions.
9576
9577 if Is_Concurrent_Type (Typ) then
9578 Is_Conc := True;
9579 Utyp := Corresponding_Record_Type (Typ);
9580 Ref := Convert_Concurrent (Obj_Ref, Typ);
9581
9582 elsif Is_Private_Type (Typ)
9583 and then Present (Full_View (Typ))
9584 and then Is_Concurrent_Type (Underlying_Type (Typ))
9585 then
9586 Is_Conc := True;
9587 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
9588 Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
9589
9590 else
9591 Is_Conc := False;
9592 Utyp := Typ;
9593 Ref := Obj_Ref;
9594 end if;
9595
9596 Set_Assignment_OK (Ref);
9597
9598 Utyp := Underlying_Type (Base_Type (Utyp));
9599
9600 -- Deal with untagged derivation of private views
9601
9602 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
9603 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
9604 Ref := Unchecked_Convert_To (Utyp, Ref);
9605
9606 -- The following is to prevent problems with UC see 1.156 RH ???
9607
9608 Set_Assignment_OK (Ref);
9609 end if;
9610
9611 -- If the underlying_type is a subtype, then we are dealing with the
9612 -- completion of a private type. We need to access the base type and
9613 -- generate a conversion to it.
9614
9615 if Utyp /= Base_Type (Utyp) then
9616 pragma Assert (Is_Private_Type (Typ));
9617 Utyp := Base_Type (Utyp);
9618 Ref := Unchecked_Convert_To (Utyp, Ref);
9619 end if;
9620
9621 -- Select the appropriate version of initialize
9622
9623 if Has_Controlled_Component (Utyp) then
9624 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
9625 else
9626 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
9627 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
9628 end if;
9629
9630 -- The object reference may need another conversion depending on the
9631 -- type of the formal and that of the actual.
9632
9633 Ref := Convert_View (Proc, Ref);
9634
9635 -- Generate:
9636 -- [Deep_]Initialize (Ref);
9637
9638 return
9639 Make_Procedure_Call_Statement (Loc,
9640 Name =>
9641 New_Occurrence_Of (Proc, Loc),
9642 Parameter_Associations => New_List (Ref));
9643 end Make_Init_Call;
9644
9645 ------------------------------
9646 -- Make_Local_Deep_Finalize --
9647 ------------------------------
9648
9649 function Make_Local_Deep_Finalize
9650 (Typ : Entity_Id;
9651 Nam : Entity_Id) return Node_Id
9652 is
9653 Loc : constant Source_Ptr := Sloc (Typ);
9654 Formals : List_Id;
9655
9656 begin
9657 Formals := New_List (
9658
9659 -- V : in out Typ
9660
9661 Make_Parameter_Specification (Loc,
9662 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
9663 In_Present => True,
9664 Out_Present => True,
9665 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
9666
9667 -- F : Boolean := True
9668
9669 Make_Parameter_Specification (Loc,
9670 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
9671 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
9672 Expression => New_Occurrence_Of (Standard_True, Loc)));
9673
9674 -- Add the necessary number of counters to represent the initialization
9675 -- state of an object.
9676
9677 return
9678 Make_Subprogram_Body (Loc,
9679 Specification =>
9680 Make_Procedure_Specification (Loc,
9681 Defining_Unit_Name => Nam,
9682 Parameter_Specifications => Formals),
9683
9684 Declarations => No_List,
9685
9686 Handled_Statement_Sequence =>
9687 Make_Handled_Sequence_Of_Statements (Loc,
9688 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
9689 end Make_Local_Deep_Finalize;
9690
9691 ------------------------------------
9692 -- Make_Set_Finalize_Address_Call --
9693 ------------------------------------
9694
9695 function Make_Set_Finalize_Address_Call
9696 (Loc : Source_Ptr;
9697 Ptr_Typ : Entity_Id) return Node_Id
9698 is
9699 -- It is possible for Ptr_Typ to be a partial view, if the access type
9700 -- is a full view declared in the private part of a nested package, and
9701 -- the finalization actions take place when completing analysis of the
9702 -- enclosing unit. For this reason use Underlying_Type twice below.
9703
9704 Desig_Typ : constant Entity_Id :=
9705 Available_View
9706 (Designated_Type (Underlying_Type (Ptr_Typ)));
9707 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
9708 Fin_Mas : constant Entity_Id :=
9709 Finalization_Master (Underlying_Type (Ptr_Typ));
9710
9711 begin
9712 -- Both the finalization master and primitive Finalize_Address must be
9713 -- available.
9714
9715 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
9716
9717 -- Generate:
9718 -- Set_Finalize_Address
9719 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
9720
9721 return
9722 Make_Procedure_Call_Statement (Loc,
9723 Name =>
9724 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
9725 Parameter_Associations => New_List (
9726 New_Occurrence_Of (Fin_Mas, Loc),
9727
9728 Make_Attribute_Reference (Loc,
9729 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
9730 Attribute_Name => Name_Unrestricted_Access)));
9731 end Make_Set_Finalize_Address_Call;
9732
9733 --------------------------
9734 -- Make_Transient_Block --
9735 --------------------------
9736
9737 function Make_Transient_Block
9738 (Loc : Source_Ptr;
9739 Action : Node_Id;
9740 Par : Node_Id) return Node_Id
9741 is
9742 Decls : constant List_Id := New_List;
9743 Instrs : constant List_Id := New_List (Action);
9744 Block : Node_Id;
9745 Insert : Node_Id;
9746
9747 begin
9748 -- Case where only secondary stack use is involved
9749
9750 if Uses_Sec_Stack (Current_Scope)
9751 and then Nkind (Action) /= N_Simple_Return_Statement
9752 and then Nkind (Par) /= N_Exception_Handler
9753 then
9754 declare
9755 S : Entity_Id;
9756
9757 begin
9758 S := Scope (Current_Scope);
9759 loop
9760 -- At the outer level, no need to release the sec stack
9761
9762 if S = Standard_Standard then
9763 Set_Uses_Sec_Stack (Current_Scope, False);
9764 exit;
9765
9766 -- In a function, only release the sec stack if the function
9767 -- does not return on the sec stack otherwise the result may
9768 -- be lost. The caller is responsible for releasing.
9769
9770 elsif Ekind (S) = E_Function then
9771 Set_Uses_Sec_Stack (Current_Scope, False);
9772
9773 if not Requires_Transient_Scope (Etype (S)) then
9774 Set_Uses_Sec_Stack (S, True);
9775 Check_Restriction (No_Secondary_Stack, Action);
9776 end if;
9777
9778 exit;
9779
9780 -- In a loop or entry we should install a block encompassing
9781 -- all the construct. For now just release right away.
9782
9783 elsif Ekind_In (S, E_Entry, E_Loop) then
9784 exit;
9785
9786 -- In a procedure or a block, release the sec stack on exit
9787 -- from the construct. Note that an exception handler with a
9788 -- choice parameter requires a declarative region in the form
9789 -- of a block. The block does not physically manifest in the
9790 -- tree as it only serves as a scope. Do not consider such a
9791 -- block because it will never release the sec stack.
9792
9793 -- ??? Memory leak can be created by recursive calls
9794
9795 elsif Ekind (S) = E_Procedure
9796 or else (Ekind (S) = E_Block
9797 and then not Is_Exception_Handler (S))
9798 then
9799 Set_Uses_Sec_Stack (Current_Scope, False);
9800 Set_Uses_Sec_Stack (S, True);
9801 Check_Restriction (No_Secondary_Stack, Action);
9802 exit;
9803
9804 else
9805 S := Scope (S);
9806 end if;
9807 end loop;
9808 end;
9809 end if;
9810
9811 -- Create the transient block. Set the parent now since the block itself
9812 -- is not part of the tree. The current scope is the E_Block entity
9813 -- that has been pushed by Establish_Transient_Scope.
9814
9815 pragma Assert (Ekind (Current_Scope) = E_Block);
9816 Block :=
9817 Make_Block_Statement (Loc,
9818 Identifier => New_Occurrence_Of (Current_Scope, Loc),
9819 Declarations => Decls,
9820 Handled_Statement_Sequence =>
9821 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
9822 Has_Created_Identifier => True);
9823 Set_Parent (Block, Par);
9824
9825 -- Insert actions stuck in the transient scopes as well as all freezing
9826 -- nodes needed by those actions. Do not insert cleanup actions here,
9827 -- they will be transferred to the newly created block.
9828
9829 Insert_Actions_In_Scope_Around
9830 (Action, Clean => False, Manage_SS => False);
9831
9832 Insert := Prev (Action);
9833 if Present (Insert) then
9834 Freeze_All (First_Entity (Current_Scope), Insert);
9835 end if;
9836
9837 -- Transfer cleanup actions to the newly created block
9838
9839 declare
9840 Cleanup_Actions : List_Id
9841 renames Scope_Stack.Table (Scope_Stack.Last).
9842 Actions_To_Be_Wrapped (Cleanup);
9843 begin
9844 Set_Cleanup_Actions (Block, Cleanup_Actions);
9845 Cleanup_Actions := No_List;
9846 end;
9847
9848 -- When the transient scope was established, we pushed the entry for the
9849 -- transient scope onto the scope stack, so that the scope was active
9850 -- for the installation of finalizable entities etc. Now we must remove
9851 -- this entry, since we have constructed a proper block.
9852
9853 Pop_Scope;
9854
9855 return Block;
9856 end Make_Transient_Block;
9857
9858 ------------------------
9859 -- Node_To_Be_Wrapped --
9860 ------------------------
9861
9862 function Node_To_Be_Wrapped return Node_Id is
9863 begin
9864 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
9865 end Node_To_Be_Wrapped;
9866
9867 ----------------------------
9868 -- Set_Node_To_Be_Wrapped --
9869 ----------------------------
9870
9871 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
9872 begin
9873 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
9874 end Set_Node_To_Be_Wrapped;
9875
9876 ----------------------------
9877 -- Store_Actions_In_Scope --
9878 ----------------------------
9879
9880 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
9881 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
9882 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
9883
9884 begin
9885 if No (Actions) then
9886 Actions := L;
9887
9888 if Is_List_Member (SE.Node_To_Be_Wrapped) then
9889 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
9890 else
9891 Set_Parent (L, SE.Node_To_Be_Wrapped);
9892 end if;
9893
9894 Analyze_List (L);
9895
9896 elsif AK = Before then
9897 Insert_List_After_And_Analyze (Last (Actions), L);
9898
9899 else
9900 Insert_List_Before_And_Analyze (First (Actions), L);
9901 end if;
9902 end Store_Actions_In_Scope;
9903
9904 ----------------------------------
9905 -- Store_After_Actions_In_Scope --
9906 ----------------------------------
9907
9908 procedure Store_After_Actions_In_Scope (L : List_Id) is
9909 begin
9910 Store_Actions_In_Scope (After, L);
9911 end Store_After_Actions_In_Scope;
9912
9913 -----------------------------------
9914 -- Store_Before_Actions_In_Scope --
9915 -----------------------------------
9916
9917 procedure Store_Before_Actions_In_Scope (L : List_Id) is
9918 begin
9919 Store_Actions_In_Scope (Before, L);
9920 end Store_Before_Actions_In_Scope;
9921
9922 -----------------------------------
9923 -- Store_Cleanup_Actions_In_Scope --
9924 -----------------------------------
9925
9926 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
9927 begin
9928 Store_Actions_In_Scope (Cleanup, L);
9929 end Store_Cleanup_Actions_In_Scope;
9930
9931 --------------------------------
9932 -- Wrap_Transient_Declaration --
9933 --------------------------------
9934
9935 -- If a transient scope has been established during the processing of the
9936 -- Expression of an Object_Declaration, it is not possible to wrap the
9937 -- declaration into a transient block as usual case, otherwise the object
9938 -- would be itself declared in the wrong scope. Therefore, all entities (if
9939 -- any) defined in the transient block are moved to the proper enclosing
9940 -- scope. Furthermore, if they are controlled variables they are finalized
9941 -- right after the declaration. The finalization list of the transient
9942 -- scope is defined as a renaming of the enclosing one so during their
9943 -- initialization they will be attached to the proper finalization list.
9944 -- For instance, the following declaration :
9945
9946 -- X : Typ := F (G (A), G (B));
9947
9948 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9949 -- is expanded into :
9950
9951 -- X : Typ := [ complex Expression-Action ];
9952 -- [Deep_]Finalize (_v1);
9953 -- [Deep_]Finalize (_v2);
9954
9955 procedure Wrap_Transient_Declaration (N : Node_Id) is
9956 Curr_S : Entity_Id;
9957 Encl_S : Entity_Id;
9958
9959 begin
9960 Curr_S := Current_Scope;
9961 Encl_S := Scope (Curr_S);
9962
9963 -- Insert all actions including cleanup generated while analyzing or
9964 -- expanding the transient context back into the tree. Manage the
9965 -- secondary stack when the object declaration appears in a library
9966 -- level package [body].
9967
9968 Insert_Actions_In_Scope_Around
9969 (N => N,
9970 Clean => True,
9971 Manage_SS =>
9972 Uses_Sec_Stack (Curr_S)
9973 and then Nkind (N) = N_Object_Declaration
9974 and then Ekind_In (Encl_S, E_Package, E_Package_Body)
9975 and then Is_Library_Level_Entity (Encl_S));
9976 Pop_Scope;
9977
9978 -- Relocate local entities declared within the transient scope to the
9979 -- enclosing scope. This action sets their Is_Public flag accordingly.
9980
9981 Transfer_Entities (Curr_S, Encl_S);
9982
9983 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9984 -- is properly released upon exiting the said scope.
9985
9986 if Uses_Sec_Stack (Curr_S) then
9987 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
9988
9989 -- Do not mark a function that returns on the secondary stack as the
9990 -- reclamation is done by the caller.
9991
9992 if Ekind (Curr_S) = E_Function
9993 and then Requires_Transient_Scope (Etype (Curr_S))
9994 then
9995 null;
9996
9997 -- Otherwise mark the enclosing dynamic scope
9998
9999 else
10000 Set_Uses_Sec_Stack (Curr_S);
10001 Check_Restriction (No_Secondary_Stack, N);
10002 end if;
10003 end if;
10004 end Wrap_Transient_Declaration;
10005
10006 -------------------------------
10007 -- Wrap_Transient_Expression --
10008 -------------------------------
10009
10010 procedure Wrap_Transient_Expression (N : Node_Id) is
10011 Loc : constant Source_Ptr := Sloc (N);
10012 Expr : Node_Id := Relocate_Node (N);
10013 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
10014 Typ : constant Entity_Id := Etype (N);
10015
10016 begin
10017 -- Generate:
10018
10019 -- Temp : Typ;
10020 -- declare
10021 -- M : constant Mark_Id := SS_Mark;
10022 -- procedure Finalizer is ... (See Build_Finalizer)
10023
10024 -- begin
10025 -- Temp := <Expr>; -- general case
10026 -- Temp := (if <Expr> then True else False); -- boolean case
10027
10028 -- at end
10029 -- Finalizer;
10030 -- end;
10031
10032 -- A special case is made for Boolean expressions so that the back-end
10033 -- knows to generate a conditional branch instruction, if running with
10034 -- -fpreserve-control-flow. This ensures that a control flow change
10035 -- signalling the decision outcome occurs before the cleanup actions.
10036
10037 if Opt.Suppress_Control_Flow_Optimizations
10038 and then Is_Boolean_Type (Typ)
10039 then
10040 Expr :=
10041 Make_If_Expression (Loc,
10042 Expressions => New_List (
10043 Expr,
10044 New_Occurrence_Of (Standard_True, Loc),
10045 New_Occurrence_Of (Standard_False, Loc)));
10046 end if;
10047
10048 Insert_Actions (N, New_List (
10049 Make_Object_Declaration (Loc,
10050 Defining_Identifier => Temp,
10051 Object_Definition => New_Occurrence_Of (Typ, Loc)),
10052
10053 Make_Transient_Block (Loc,
10054 Action =>
10055 Make_Assignment_Statement (Loc,
10056 Name => New_Occurrence_Of (Temp, Loc),
10057 Expression => Expr),
10058 Par => Parent (N))));
10059
10060 Rewrite (N, New_Occurrence_Of (Temp, Loc));
10061 Analyze_And_Resolve (N, Typ);
10062 end Wrap_Transient_Expression;
10063
10064 ------------------------------
10065 -- Wrap_Transient_Statement --
10066 ------------------------------
10067
10068 procedure Wrap_Transient_Statement (N : Node_Id) is
10069 Loc : constant Source_Ptr := Sloc (N);
10070 New_Stmt : constant Node_Id := Relocate_Node (N);
10071
10072 begin
10073 -- Generate:
10074 -- declare
10075 -- M : constant Mark_Id := SS_Mark;
10076 -- procedure Finalizer is ... (See Build_Finalizer)
10077 --
10078 -- begin
10079 -- <New_Stmt>;
10080 --
10081 -- at end
10082 -- Finalizer;
10083 -- end;
10084
10085 Rewrite (N,
10086 Make_Transient_Block (Loc,
10087 Action => New_Stmt,
10088 Par => Parent (N)));
10089
10090 -- With the scope stack back to normal, we can call analyze on the
10091 -- resulting block. At this point, the transient scope is being
10092 -- treated like a perfectly normal scope, so there is nothing
10093 -- special about it.
10094
10095 -- Note: Wrap_Transient_Statement is called with the node already
10096 -- analyzed (i.e. Analyzed (N) is True). This is important, since
10097 -- otherwise we would get a recursive processing of the node when
10098 -- we do this Analyze call.
10099
10100 Analyze (N);
10101 end Wrap_Transient_Statement;
10102
10103 end Exp_Ch7;