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