]>
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 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, 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 | ||
104f58db BD |
30 | with Atree; use Atree; |
31 | with Contracts; use Contracts; | |
32 | with Debug; use Debug; | |
33 | with Einfo; use Einfo; | |
76f9c7f4 | 34 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
35 | with Einfo.Utils; use Einfo.Utils; |
36 | with Elists; use Elists; | |
37 | with Errout; use Errout; | |
38 | with Exp_Ch6; use Exp_Ch6; | |
39 | with Exp_Ch9; use Exp_Ch9; | |
40 | with Exp_Ch11; use Exp_Ch11; | |
41 | with Exp_Dbug; use Exp_Dbug; | |
42 | with Exp_Dist; use Exp_Dist; | |
43 | with Exp_Disp; use Exp_Disp; | |
44 | with Exp_Prag; use Exp_Prag; | |
45 | with Exp_Tss; use Exp_Tss; | |
46 | with Exp_Util; use Exp_Util; | |
47 | with Freeze; use Freeze; | |
48 | with GNAT_CUDA; use GNAT_CUDA; | |
49 | with Lib; use Lib; | |
50 | with Nlists; use Nlists; | |
51 | with Nmake; use Nmake; | |
52 | with Opt; use Opt; | |
53 | with Output; use Output; | |
54 | with Restrict; use Restrict; | |
55 | with Rident; use Rident; | |
56 | with Rtsfind; use Rtsfind; | |
57 | with Sinfo; use Sinfo; | |
58 | with Sinfo.Nodes; use Sinfo.Nodes; | |
59 | with Sinfo.Utils; use Sinfo.Utils; | |
60 | with Sem; use Sem; | |
61 | with Sem_Aux; use Sem_Aux; | |
62 | with Sem_Ch3; use Sem_Ch3; | |
63 | with Sem_Ch7; use Sem_Ch7; | |
64 | with Sem_Ch8; use Sem_Ch8; | |
65 | with Sem_Res; use Sem_Res; | |
66 | with Sem_Util; use Sem_Util; | |
67 | with Snames; use Snames; | |
68 | with Stand; use Stand; | |
69 | with Tbuild; use Tbuild; | |
70 | with Ttypes; use Ttypes; | |
71 | with Uintp; use Uintp; | |
70482933 RK |
72 | |
73 | package body Exp_Ch7 is | |
74 | ||
75 | -------------------------------- | |
76 | -- Transient Scope Management -- | |
77 | -------------------------------- | |
78 | ||
79 | -- A transient scope is created when temporary objects are created by the | |
80 | -- compiler. These temporary objects are allocated on the secondary stack | |
81 | -- and the transient scope is responsible for finalizing the object when | |
82 | -- appropriate and reclaiming the memory at the right time. The temporary | |
83 | -- objects are generally the objects allocated to store the result of a | |
84 | -- function returning an unconstrained or a tagged value. Expressions | |
85 | -- needing to be wrapped in a transient scope (functions calls returning | |
86 | -- unconstrained or tagged values) may appear in 3 different contexts which | |
87 | -- lead to 3 different kinds of transient scope expansion: | |
88 | ||
886b5a18 AC |
89 | -- 1. In a simple statement (procedure call, assignment, ...). In this |
90 | -- case the instruction is wrapped into a transient block. See | |
91 | -- Wrap_Transient_Statement for details. | |
70482933 RK |
92 | |
93 | -- 2. In an expression of a control structure (test in a IF statement, | |
886b5a18 AC |
94 | -- expression in a CASE statement, ...). See Wrap_Transient_Expression |
95 | -- for details. | |
70482933 RK |
96 | |
97 | -- 3. In a expression of an object_declaration. No wrapping is possible | |
36c73552 | 98 | -- here, so the finalization actions, if any, are done right after the |
70482933 | 99 | -- declaration and the secondary stack deallocation is done in the |
886b5a18 | 100 | -- proper enclosing scope. See Wrap_Transient_Declaration for details. |
70482933 | 101 | |
36c73552 | 102 | -- Note about functions returning tagged types: it has been decided to |
dbe13a37 | 103 | -- always allocate their result in the secondary stack, even though is not |
70482933 RK |
104 | -- absolutely mandatory when the tagged type is constrained because the |
105 | -- caller knows the size of the returned object and thus could allocate the | |
dbe13a37 ES |
106 | -- result in the primary stack. An exception to this is when the function |
107 | -- builds its result in place, as is done for functions with inherently | |
108 | -- limited result types for Ada 2005. In that case, certain callers may | |
109 | -- pass the address of a constrained object as the target object for the | |
110 | -- function result. | |
70482933 | 111 | |
dbe13a37 ES |
112 | -- By allocating tagged results in the secondary stack a number of |
113 | -- implementation difficulties are avoided: | |
114 | ||
115 | -- - If it is a dispatching function call, the computation of the size of | |
70482933 RK |
116 | -- the result is possible but complex from the outside. |
117 | ||
118 | -- - If the returned type is controlled, the assignment of the returned | |
119 | -- value to the anonymous object involves an Adjust, and we have no | |
dbe13a37 | 120 | -- easy way to access the anonymous object created by the back end. |
70482933 RK |
121 | |
122 | -- - If the returned type is class-wide, this is an unconstrained type | |
dbe13a37 | 123 | -- anyway. |
70482933 | 124 | |
dbe13a37 ES |
125 | -- Furthermore, the small loss in efficiency which is the result of this |
126 | -- decision is not such a big deal because functions returning tagged types | |
127 | -- are not as common in practice compared to functions returning access to | |
128 | -- a tagged type. | |
70482933 RK |
129 | |
130 | -------------------------------------------------- | |
131 | -- Transient Blocks and Finalization Management -- | |
132 | -------------------------------------------------- | |
133 | ||
66c0fa2c HK |
134 | function Find_Transient_Context (N : Node_Id) return Node_Id; |
135 | -- Locate a suitable context for arbitrary node N which may need to be | |
136 | -- serviced by a transient scope. Return Empty if no suitable context is | |
137 | -- available. | |
70482933 | 138 | |
8e888920 AC |
139 | procedure Insert_Actions_In_Scope_Around |
140 | (N : Node_Id; | |
141 | Clean : Boolean; | |
142 | Manage_SS : Boolean); | |
70482933 | 143 | -- Insert the before-actions kept in the scope stack before N, and the |
8e888920 AC |
144 | -- after-actions after N, which must be a member of a list. If flag Clean |
145 | -- is set, insert any cleanup actions. If flag Manage_SS is set, insert | |
146 | -- calls to mark and release the secondary stack. | |
70482933 RK |
147 | |
148 | function Make_Transient_Block | |
149 | (Loc : Source_Ptr; | |
df3e68b1 HK |
150 | Action : Node_Id; |
151 | Par : Node_Id) return Node_Id; | |
152 | -- Action is a single statement or object declaration. Par is the proper | |
153 | -- parent of the generated block. Create a transient block whose name is | |
154 | -- the current scope and the only handled statement is Action. If Action | |
155 | -- involves controlled objects or secondary stack usage, the corresponding | |
156 | -- cleanup actions are performed at the end of the block. | |
70482933 | 157 | |
df3e68b1 HK |
158 | procedure Set_Node_To_Be_Wrapped (N : Node_Id); |
159 | -- Set the field Node_To_Be_Wrapped of the current scope | |
fbf5a39b | 160 | |
36295779 AC |
161 | procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); |
162 | -- Shared processing for Store_xxx_Actions_In_Scope | |
163 | ||
70482933 RK |
164 | ----------------------------- |
165 | -- Finalization Management -- | |
166 | ----------------------------- | |
167 | ||
8fc789c8 | 168 | -- This part describe how Initialization/Adjustment/Finalization procedures |
70482933 RK |
169 | -- are generated and called. Two cases must be considered, types that are |
170 | -- Controlled (Is_Controlled flag set) and composite types that contain | |
171 | -- controlled components (Has_Controlled_Component flag set). In the first | |
172 | -- case the procedures to call are the user-defined primitive operations | |
173 | -- Initialize/Adjust/Finalize. In the second case, GNAT generates | |
dbe13a37 ES |
174 | -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge |
175 | -- of calling the former procedures on the controlled components. | |
70482933 RK |
176 | |
177 | -- For records with Has_Controlled_Component set, a hidden "controller" | |
178 | -- component is inserted. This controller component contains its own | |
179 | -- finalization list on which all controlled components are attached | |
180 | -- creating an indirection on the upper-level Finalization list. This | |
181 | -- technique facilitates the management of objects whose number of | |
182 | -- controlled components changes during execution. This controller | |
183 | -- component is itself controlled and is attached to the upper-level | |
dbe13a37 | 184 | -- finalization chain. Its adjust primitive is in charge of calling adjust |
8fc789c8 | 185 | -- on the components and adjusting the finalization pointer to match their |
dbe13a37 | 186 | -- new location (see a-finali.adb). |
70482933 RK |
187 | |
188 | -- It is not possible to use a similar technique for arrays that have | |
189 | -- Has_Controlled_Component set. In this case, deep procedures are | |
190 | -- generated that call initialize/adjust/finalize + attachment or | |
191 | -- detachment on the finalization list for all component. | |
192 | ||
193 | -- Initialize calls: they are generated for declarations or dynamic | |
dbe13a37 ES |
194 | -- allocations of Controlled objects with no initial value. They are always |
195 | -- followed by an attachment to the current Finalization Chain. For the | |
196 | -- dynamic allocation case this the chain attached to the scope of the | |
197 | -- access type definition otherwise, this is the chain of the current | |
198 | -- scope. | |
70482933 | 199 | |
886b5a18 AC |
200 | -- Adjust Calls: They are generated on 2 occasions: (1) for declarations |
201 | -- or dynamic allocations of Controlled objects with an initial value. | |
202 | -- (2) after an assignment. In the first case they are followed by an | |
203 | -- attachment to the final chain, in the second case they are not. | |
70482933 RK |
204 | |
205 | -- Finalization Calls: They are generated on (1) scope exit, (2) | |
206 | -- assignments, (3) unchecked deallocations. In case (3) they have to | |
207 | -- be detached from the final chain, in case (2) they must not and in | |
dbe13a37 | 208 | -- case (1) this is not important since we are exiting the scope anyway. |
70482933 | 209 | |
fbf5a39b | 210 | -- Other details: |
dbe13a37 ES |
211 | |
212 | -- Type extensions will have a new record controller at each derivation | |
213 | -- level containing controlled components. The record controller for | |
214 | -- the parent/ancestor is attached to the finalization list of the | |
215 | -- extension's record controller (i.e. the parent is like a component | |
216 | -- of the extension). | |
217 | ||
218 | -- For types that are both Is_Controlled and Has_Controlled_Components, | |
219 | -- the record controller and the object itself are handled separately. | |
220 | -- It could seem simpler to attach the object at the end of its record | |
221 | -- controller but this would not tackle view conversions properly. | |
222 | ||
223 | -- A classwide type can always potentially have controlled components | |
224 | -- but the record controller of the corresponding actual type may not | |
225 | -- be known at compile time so the dispatch table contains a special | |
6782b1ef | 226 | -- field that allows computation of the offset of the record controller |
dbe13a37 | 227 | -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. |
fbf5a39b | 228 | |
70482933 RK |
229 | -- Here is a simple example of the expansion of a controlled block : |
230 | ||
231 | -- declare | |
33c423c8 | 232 | -- X : Controlled; |
70482933 RK |
233 | -- Y : Controlled := Init; |
234 | -- | |
235 | -- type R is record | |
236 | -- C : Controlled; | |
237 | -- end record; | |
238 | -- W : R; | |
239 | -- Z : R := (C => X); | |
886b5a18 | 240 | |
70482933 RK |
241 | -- begin |
242 | -- X := Y; | |
243 | -- W := Z; | |
244 | -- end; | |
245 | -- | |
246 | -- is expanded into | |
247 | -- | |
248 | -- declare | |
249 | -- _L : System.FI.Finalizable_Ptr; | |
250 | ||
251 | -- procedure _Clean is | |
252 | -- begin | |
253 | -- Abort_Defer; | |
254 | -- System.FI.Finalize_List (_L); | |
255 | -- Abort_Undefer; | |
256 | -- end _Clean; | |
257 | ||
258 | -- X : Controlled; | |
fbf5a39b AC |
259 | -- begin |
260 | -- Abort_Defer; | |
261 | -- Initialize (X); | |
262 | -- Attach_To_Final_List (_L, Finalizable (X), 1); | |
263 | -- at end: Abort_Undefer; | |
70482933 RK |
264 | -- Y : Controlled := Init; |
265 | -- Adjust (Y); | |
266 | -- Attach_To_Final_List (_L, Finalizable (Y), 1); | |
267 | -- | |
268 | -- type R is record | |
70482933 RK |
269 | -- C : Controlled; |
270 | -- end record; | |
271 | -- W : R; | |
fbf5a39b AC |
272 | -- begin |
273 | -- Abort_Defer; | |
274 | -- Deep_Initialize (W, _L, 1); | |
275 | -- at end: Abort_Under; | |
70482933 RK |
276 | -- Z : R := (C => X); |
277 | -- Deep_Adjust (Z, _L, 1); | |
278 | ||
279 | -- begin | |
fbf5a39b | 280 | -- _Assign (X, Y); |
70482933 | 281 | -- Deep_Finalize (W, False); |
fbf5a39b | 282 | -- <save W's final pointers> |
70482933 | 283 | -- W := Z; |
fbf5a39b | 284 | -- <restore W's final pointers> |
70482933 RK |
285 | -- Deep_Adjust (W, _L, 0); |
286 | -- at end | |
287 | -- _Clean; | |
288 | -- end; | |
289 | ||
df3e68b1 HK |
290 | type Final_Primitives is |
291 | (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case); | |
292 | -- This enumeration type is defined in order to ease sharing code for | |
293 | -- building finalization procedures for composite types. | |
294 | ||
295 | Name_Of : constant array (Final_Primitives) of Name_Id := | |
296 | (Initialize_Case => Name_Initialize, | |
297 | Adjust_Case => Name_Adjust, | |
298 | Finalize_Case => Name_Finalize, | |
299 | Address_Case => Name_Finalize_Address); | |
df3e68b1 HK |
300 | Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := |
301 | (Initialize_Case => TSS_Deep_Initialize, | |
302 | Adjust_Case => TSS_Deep_Adjust, | |
303 | Finalize_Case => TSS_Deep_Finalize, | |
304 | Address_Case => TSS_Finalize_Address); | |
305 | ||
32b794c8 AC |
306 | function Allows_Finalization_Master (Typ : Entity_Id) return Boolean; |
307 | -- Determine whether access type Typ may have a finalization master | |
308 | ||
df3e68b1 HK |
309 | procedure Build_Array_Deep_Procs (Typ : Entity_Id); |
310 | -- Build the deep Initialize/Adjust/Finalize for a record Typ with | |
311 | -- Has_Controlled_Component set and store them using the TSS mechanism. | |
312 | ||
36295779 AC |
313 | function Build_Cleanup_Statements |
314 | (N : Node_Id; | |
315 | Additional_Cleanup : List_Id) return List_Id; | |
40c21e91 | 316 | -- Create the cleanup calls for an asynchronous call block, task master, |
36295779 AC |
317 | -- protected subprogram body, task allocation block or task body, or |
318 | -- additional cleanup actions parked on a transient block. If the context | |
319 | -- does not contain the above constructs, the routine returns an empty | |
320 | -- list. | |
df3e68b1 | 321 | |
df3e68b1 HK |
322 | procedure Build_Finalizer |
323 | (N : Node_Id; | |
324 | Clean_Stmts : List_Id; | |
325 | Mark_Id : Entity_Id; | |
326 | Top_Decls : List_Id; | |
327 | Defer_Abort : Boolean; | |
328 | Fin_Id : out Entity_Id); | |
329 | -- N may denote an accept statement, block, entry body, package body, | |
7b56a91b | 330 | -- package spec, protected body, subprogram body, or a task body. Create |
df3e68b1 HK |
331 | -- a procedure which contains finalization calls for all controlled objects |
332 | -- declared in the declarative or statement region of N. The calls are | |
333 | -- built in reverse order relative to the original declarations. In the | |
7b56a91b | 334 | -- case of a task body, the routine delays the creation of the finalizer |
df3e68b1 HK |
335 | -- until all statements have been moved to the task body procedure. |
336 | -- Clean_Stmts may contain additional context-dependent code used to abort | |
337 | -- asynchronous calls or complete tasks (see Build_Cleanup_Statements). | |
338 | -- Mark_Id is the secondary stack used in the current context or Empty if | |
339 | -- missing. Top_Decls is the list on which the declaration of the finalizer | |
340 | -- is attached in the non-package case. Defer_Abort indicates that the | |
341 | -- statements passed in perform actions that require abort to be deferred, | |
342 | -- such as for task termination. Fin_Id is the finalizer declaration | |
343 | -- entity. | |
344 | ||
a1023434 JS |
345 | procedure Build_Finalizer_Helper |
346 | (N : Node_Id; | |
347 | Clean_Stmts : List_Id; | |
348 | Mark_Id : Entity_Id; | |
349 | Top_Decls : List_Id; | |
350 | Defer_Abort : Boolean; | |
351 | Fin_Id : out Entity_Id; | |
352 | Finalize_Old_Only : Boolean); | |
353 | -- An internal routine which does all of the heavy lifting on behalf of | |
354 | -- Build_Finalizer. | |
355 | ||
df3e68b1 HK |
356 | procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); |
357 | -- N is a construct which contains a handled sequence of statements, Fin_Id | |
358 | -- is the entity of a finalizer. Create an At_End handler which covers the | |
359 | -- statements of N and calls Fin_Id. If the handled statement sequence has | |
360 | -- an exception handler, the statements will be wrapped in a block to avoid | |
361 | -- unwanted interaction with the new At_End handler. | |
362 | ||
df3e68b1 HK |
363 | procedure Build_Record_Deep_Procs (Typ : Entity_Id); |
364 | -- Build the deep Initialize/Adjust/Finalize for a record Typ with | |
365 | -- Has_Component_Component set and store them using the TSS mechanism. | |
366 | ||
e60c10b3 ES |
367 | ------------------------------------------- |
368 | -- Unnesting procedures for CCG and LLVM -- | |
369 | ------------------------------------------- | |
370 | ||
371 | -- Expansion generates subprograms for controlled types management that | |
372 | -- may appear in declarative lists in package declarations and bodies. | |
373 | -- These subprograms appear within generated blocks that contain local | |
374 | -- declarations and a call to finalization procedures. To ensure that | |
375 | -- such subprograms get activation records when needed, we transform the | |
376 | -- block into a procedure body, followed by a call to it in the same | |
377 | -- declarative list. | |
378 | ||
86f32857 ES |
379 | procedure Check_Unnesting_Elaboration_Code (N : Node_Id); |
380 | -- The statement part of a package body that is a compilation unit may | |
f68289d8 | 381 | -- contain blocks that declare local subprograms. In Subprogram_Unnesting_ |
86f32857 ES |
382 | -- Mode such subprograms must be handled as nested inside the (implicit) |
383 | -- elaboration procedure that executes that statement part. To handle | |
384 | -- properly uplevel references we construct that subprogram explicitly, | |
e8bb6ff9 | 385 | -- to contain blocks and inner subprograms, the statement part becomes |
86f32857 | 386 | -- a call to this subprogram. This is only done if blocks are present |
f68289d8 GD |
387 | -- in the statement list of the body. (It would be nice to unify this |
388 | -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since | |
389 | -- they're doing very similar work, but are structured differently. ???) | |
390 | ||
391 | procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id); | |
392 | -- Similarly, the declarations or statements in library-level packages may | |
604801a4 | 393 | -- have created blocks with nested subprograms. Such a block must be |
f68289d8 GD |
394 | -- transformed into a procedure followed by a call to it, so that unnesting |
395 | -- can handle uplevel references within these nested subprograms (typically | |
396 | -- subprograms that handle finalization actions). This also applies to | |
397 | -- nested packages, including instantiations, in which case it must | |
398 | -- recursively process inner bodies. | |
399 | ||
400 | procedure Check_Unnesting_In_Handlers (N : Node_Id); | |
401 | -- Similarly, check for blocks with nested subprograms occurring within | |
402 | -- a set of exception handlers associated with a package body N. | |
403 | ||
404 | procedure Unnest_Block (Decl : Node_Id); | |
405 | -- Blocks that contain nested subprograms with up-level references need to | |
406 | -- create activation records for them. We do this by rewriting the block as | |
407 | -- a procedure, followed by a call to it in the same declarative list, to | |
408 | -- replicate the semantics of the original block. | |
409 | -- | |
410 | -- A common source for such block is a transient block created for a | |
411 | -- construct (declaration, assignment, etc.) that involves controlled | |
412 | -- actions or secondary-stack management, in which case the nested | |
413 | -- subprogram is a finalizer. | |
302319e0 | 414 | |
05746958 GD |
415 | procedure Unnest_If_Statement (If_Stmt : Node_Id); |
416 | -- The separate statement lists associated with an if-statement (then part, | |
417 | -- elsif parts, else part) may require unnesting if they directly contain | |
418 | -- a subprogram body that references up-level objects. Each statement list | |
419 | -- is traversed to locate such subprogram bodies, and if a part's statement | |
420 | -- list contains a body, then the list is replaced with a new procedure | |
421 | -- containing the part's statements followed by a call to the procedure. | |
422 | -- Furthermore, any nested blocks, loops, or if statements will also be | |
423 | -- traversed to determine the need for further unnesting transformations. | |
424 | ||
425 | procedure Unnest_Statement_List (Stmts : in out List_Id); | |
426 | -- A list of statements that directly contains a subprogram at its outer | |
427 | -- level, that may reference objects declared in that same statement list, | |
428 | -- is rewritten as a procedure containing the statement list Stmts (which | |
429 | -- includes any such objects as well as the nested subprogram), followed by | |
430 | -- a call to the new procedure, and Stmts becomes the list containing the | |
431 | -- procedure and the call. This ensures that Unnest_Subprogram will later | |
432 | -- properly handle up-level references from the nested subprogram to | |
433 | -- objects declared earlier in statement list, by creating an activation | |
434 | -- record and passing it to the nested subprogram. This procedure also | |
435 | -- resets the Scope of objects declared in the statement list, as well as | |
436 | -- the Scope of the nested subprogram, to refer to the new procedure. | |
437 | -- Also, the new procedure is marked Has_Nested_Subprogram, so this should | |
438 | -- only be called when known that the statement list contains a subprogram. | |
439 | ||
7e536bfd GD |
440 | procedure Unnest_Loop (Loop_Stmt : Node_Id); |
441 | -- Top-level Loops that contain nested subprograms with up-level references | |
442 | -- need to have activation records. We do this by rewriting the loop as a | |
443 | -- procedure containing the loop, followed by a call to the procedure in | |
444 | -- the same library-level declarative list, to replicate the semantics of | |
445 | -- the original loop. Such loops can occur due to aggregate expansions and | |
446 | -- other constructs. | |
447 | ||
df3e68b1 HK |
448 | procedure Check_Visibly_Controlled |
449 | (Prim : Final_Primitives; | |
450 | Typ : Entity_Id; | |
451 | E : in out Entity_Id; | |
452 | Cref : in out Node_Id); | |
453 | -- The controlled operation declared for a derived type may not be | |
454 | -- overriding, if the controlled operations of the parent type are hidden, | |
455 | -- for example when the parent is a private type whose full view is | |
456 | -- controlled. For other primitive operations we modify the name of the | |
457 | -- operation to indicate that it is not overriding, but this is not | |
458 | -- possible for Initialize, etc. because they have to be retrievable by | |
459 | -- name. Before generating the proper call to one of these operations we | |
460 | -- check whether Typ is known to be controlled at the point of definition. | |
461 | -- If it is not then we must retrieve the hidden operation of the parent | |
64ac53f4 | 462 | -- and use it instead. This is one case that might be solved more cleanly |
df3e68b1 HK |
463 | -- once Overriding pragmas or declarations are in place. |
464 | ||
68f27c97 HK |
465 | function Contains_Subprogram (Blk : Entity_Id) return Boolean; |
466 | -- Check recursively whether a loop or block contains a subprogram that | |
467 | -- may need an activation record. | |
468 | ||
df3e68b1 HK |
469 | function Convert_View |
470 | (Proc : Entity_Id; | |
471 | Arg : Node_Id; | |
472 | Ind : Pos := 1) return Node_Id; | |
473 | -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the | |
474 | -- argument being passed to it. Ind indicates which formal of procedure | |
475 | -- Proc we are trying to match. This function will, if necessary, generate | |
476 | -- a conversion between the partial and full view of Arg to match the type | |
477 | -- of the formal of Proc, or force a conversion to the class-wide type in | |
478 | -- the case where the operation is abstract. | |
479 | ||
480 | function Enclosing_Function (E : Entity_Id) return Entity_Id; | |
481 | -- Given an arbitrary entity, traverse the scope chain looking for the | |
482 | -- first enclosing function. Return Empty if no function was found. | |
483 | ||
484 | function Make_Call | |
4ac2bbbd AC |
485 | (Loc : Source_Ptr; |
486 | Proc_Id : Entity_Id; | |
487 | Param : Node_Id; | |
488 | Skip_Self : Boolean := False) return Node_Id; | |
df3e68b1 | 489 | -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of |
4ac2bbbd AC |
490 | -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create |
491 | -- an adjust or finalization call. Wnen flag Skip_Self is set, the related | |
492 | -- action has an effect on the components only (if any). | |
df3e68b1 HK |
493 | |
494 | function Make_Deep_Proc | |
495 | (Prim : Final_Primitives; | |
496 | Typ : Entity_Id; | |
497 | Stmts : List_Id) return Node_Id; | |
498 | -- This function generates the tree for Deep_Initialize, Deep_Adjust or | |
499 | -- Deep_Finalize procedures according to the first parameter, these | |
500 | -- procedures operate on the type Typ. The Stmts parameter gives the body | |
501 | -- of the procedure. | |
502 | ||
503 | function Make_Deep_Array_Body | |
504 | (Prim : Final_Primitives; | |
505 | Typ : Entity_Id) return List_Id; | |
506 | -- This function generates the list of statements for implementing | |
507 | -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to | |
508 | -- the first parameter, these procedures operate on the array type Typ. | |
509 | ||
510 | function Make_Deep_Record_Body | |
511 | (Prim : Final_Primitives; | |
512 | Typ : Entity_Id; | |
513 | Is_Local : Boolean := False) return List_Id; | |
514 | -- This function generates the list of statements for implementing | |
515 | -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to | |
516 | -- the first parameter, these procedures operate on the record type Typ. | |
517 | -- Flag Is_Local is used in conjunction with Deep_Finalize to designate | |
518 | -- whether the inner logic should be dictated by state counters. | |
70482933 | 519 | |
df3e68b1 | 520 | function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id; |
d3f70b35 AC |
521 | -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and |
522 | -- Make_Deep_Record_Body. Generate the following statements: | |
df3e68b1 HK |
523 | -- |
524 | -- declare | |
525 | -- type Acc_Typ is access all Typ; | |
526 | -- for Acc_Typ'Storage_Size use 0; | |
527 | -- begin | |
528 | -- [Deep_]Finalize (Acc_Typ (V).all); | |
529 | -- end; | |
fbf5a39b | 530 | |
32b794c8 AC |
531 | -------------------------------- |
532 | -- Allows_Finalization_Master -- | |
533 | -------------------------------- | |
534 | ||
535 | function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is | |
536 | function In_Deallocation_Instance (E : Entity_Id) return Boolean; | |
537 | -- Determine whether entity E is inside a wrapper package created for | |
538 | -- an instance of Ada.Unchecked_Deallocation. | |
539 | ||
540 | ------------------------------ | |
541 | -- In_Deallocation_Instance -- | |
542 | ------------------------------ | |
543 | ||
544 | function In_Deallocation_Instance (E : Entity_Id) return Boolean is | |
545 | Pkg : constant Entity_Id := Scope (E); | |
546 | Par : Node_Id := Empty; | |
547 | ||
548 | begin | |
549 | if Ekind (Pkg) = E_Package | |
550 | and then Present (Related_Instance (Pkg)) | |
551 | and then Ekind (Related_Instance (Pkg)) = E_Procedure | |
552 | then | |
553 | Par := Generic_Parent (Parent (Related_Instance (Pkg))); | |
554 | ||
555 | return | |
556 | Present (Par) | |
557 | and then Chars (Par) = Name_Unchecked_Deallocation | |
558 | and then Chars (Scope (Par)) = Name_Ada | |
559 | and then Scope (Scope (Par)) = Standard_Standard; | |
560 | end if; | |
561 | ||
562 | return False; | |
563 | end In_Deallocation_Instance; | |
564 | ||
565 | -- Local variables | |
566 | ||
567 | Desig_Typ : constant Entity_Id := Designated_Type (Typ); | |
568 | Ptr_Typ : constant Entity_Id := | |
569 | Root_Type_Of_Full_View (Base_Type (Typ)); | |
570 | ||
571 | -- Start of processing for Allows_Finalization_Master | |
572 | ||
573 | begin | |
574 | -- Certain run-time configurations and targets do not provide support | |
575 | -- for controlled types and therefore do not need masters. | |
576 | ||
577 | if Restriction_Active (No_Finalization) then | |
578 | return False; | |
579 | ||
580 | -- Do not consider C and C++ types since it is assumed that the non-Ada | |
40c21e91 | 581 | -- side will handle their cleanup. |
32b794c8 AC |
582 | |
583 | elsif Convention (Desig_Typ) = Convention_C | |
584 | or else Convention (Desig_Typ) = Convention_CPP | |
585 | then | |
586 | return False; | |
587 | ||
ded462b0 | 588 | -- Do not consider an access type that returns on the secondary stack |
32b794c8 AC |
589 | |
590 | elsif Present (Associated_Storage_Pool (Ptr_Typ)) | |
591 | and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) | |
592 | then | |
593 | return False; | |
594 | ||
ded462b0 | 595 | -- Do not consider an access type that can never allocate an object |
32b794c8 AC |
596 | |
597 | elsif No_Pool_Assigned (Ptr_Typ) then | |
598 | return False; | |
599 | ||
d1eb8a82 AC |
600 | -- Do not consider an access type coming from an Unchecked_Deallocation |
601 | -- instance. Even though the designated type may be controlled, the | |
602 | -- access type will never participate in any allocations. | |
32b794c8 AC |
603 | |
604 | elsif In_Deallocation_Instance (Ptr_Typ) then | |
605 | return False; | |
606 | ||
d1eb8a82 AC |
607 | -- Do not consider a non-library access type when No_Nested_Finalization |
608 | -- is in effect since finalization masters are controlled objects and if | |
609 | -- created will violate the restriction. | |
32b794c8 AC |
610 | |
611 | elsif Restriction_Active (No_Nested_Finalization) | |
612 | and then not Is_Library_Level_Entity (Ptr_Typ) | |
613 | then | |
614 | return False; | |
615 | ||
d1eb8a82 AC |
616 | -- Do not consider an access type subject to pragma No_Heap_Finalization |
617 | -- because objects allocated through such a type are not to be finalized | |
618 | -- when the access type goes out of scope. | |
619 | ||
620 | elsif No_Heap_Finalization (Ptr_Typ) then | |
621 | return False; | |
622 | ||
32b794c8 AC |
623 | -- Do not create finalization masters in GNATprove mode because this |
624 | -- causes unwanted extra expansion. A compilation in this mode must | |
625 | -- keep the tree as close as possible to the original sources. | |
626 | ||
627 | elsif GNATprove_Mode then | |
628 | return False; | |
629 | ||
630 | -- Otherwise the access type may use a finalization master | |
631 | ||
632 | else | |
633 | return True; | |
634 | end if; | |
635 | end Allows_Finalization_Master; | |
636 | ||
637 | ---------------------------- | |
638 | -- Build_Anonymous_Master -- | |
639 | ---------------------------- | |
640 | ||
641 | procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is | |
642 | function Create_Anonymous_Master | |
643 | (Desig_Typ : Entity_Id; | |
644 | Unit_Id : Entity_Id; | |
645 | Unit_Decl : Node_Id) return Entity_Id; | |
5b42c035 AC |
646 | -- Create a new anonymous master for access type Ptr_Typ with designated |
647 | -- type Desig_Typ. The declaration of the master and its initialization | |
648 | -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is | |
649 | -- the entity of Unit_Decl. | |
32b794c8 | 650 | |
5b42c035 AC |
651 | function Current_Anonymous_Master |
652 | (Desig_Typ : Entity_Id; | |
653 | Unit_Id : Entity_Id) return Entity_Id; | |
654 | -- Find an anonymous master declared within unit Unit_Id which services | |
655 | -- designated type Desig_Typ. If there is no such master, return Empty. | |
32b794c8 AC |
656 | |
657 | ----------------------------- | |
658 | -- Create_Anonymous_Master -- | |
659 | ----------------------------- | |
660 | ||
661 | function Create_Anonymous_Master | |
662 | (Desig_Typ : Entity_Id; | |
663 | Unit_Id : Entity_Id; | |
664 | Unit_Decl : Node_Id) return Entity_Id | |
665 | is | |
5b42c035 AC |
666 | Loc : constant Source_Ptr := Sloc (Unit_Id); |
667 | ||
668 | All_FMs : Elist_Id; | |
32b794c8 AC |
669 | Decls : List_Id; |
670 | FM_Decl : Node_Id; | |
671 | FM_Id : Entity_Id; | |
672 | FM_Init : Node_Id; | |
32b794c8 AC |
673 | Unit_Spec : Node_Id; |
674 | ||
675 | begin | |
5b42c035 AC |
676 | -- Generate: |
677 | -- <FM_Id> : Finalization_Master; | |
678 | ||
679 | FM_Id := Make_Temporary (Loc, 'A'); | |
680 | ||
681 | FM_Decl := | |
682 | Make_Object_Declaration (Loc, | |
683 | Defining_Identifier => FM_Id, | |
684 | Object_Definition => | |
685 | New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)); | |
686 | ||
687 | -- Generate: | |
688 | -- Set_Base_Pool | |
689 | -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access); | |
690 | ||
691 | FM_Init := | |
692 | Make_Procedure_Call_Statement (Loc, | |
693 | Name => | |
694 | New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), | |
695 | Parameter_Associations => New_List ( | |
696 | New_Occurrence_Of (FM_Id, Loc), | |
697 | Make_Attribute_Reference (Loc, | |
698 | Prefix => | |
699 | New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc), | |
700 | Attribute_Name => Name_Unrestricted_Access))); | |
701 | ||
32b794c8 AC |
702 | -- Find the declarative list of the unit |
703 | ||
704 | if Nkind (Unit_Decl) = N_Package_Declaration then | |
705 | Unit_Spec := Specification (Unit_Decl); | |
706 | Decls := Visible_Declarations (Unit_Spec); | |
707 | ||
708 | if No (Decls) then | |
709 | Decls := New_List; | |
710 | Set_Visible_Declarations (Unit_Spec, Decls); | |
711 | end if; | |
712 | ||
713 | -- Package body or subprogram case | |
714 | ||
715 | -- ??? A subprogram spec or body that acts as a compilation unit may | |
716 | -- contain a formal parameter of an anonymous access-to-controlled | |
717 | -- type initialized by an allocator. | |
718 | ||
719 | -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl); | |
720 | ||
5b42c035 AC |
721 | -- There is no suitable place to create the master as the subprogram |
722 | -- is not in a declarative list. | |
32b794c8 AC |
723 | |
724 | else | |
725 | Decls := Declarations (Unit_Decl); | |
726 | ||
727 | if No (Decls) then | |
728 | Decls := New_List; | |
729 | Set_Declarations (Unit_Decl, Decls); | |
730 | end if; | |
731 | end if; | |
732 | ||
5b42c035 AC |
733 | Prepend_To (Decls, FM_Init); |
734 | Prepend_To (Decls, FM_Decl); | |
32b794c8 | 735 | |
5b42c035 AC |
736 | -- Use the scope of the unit when analyzing the declaration of the |
737 | -- master and its initialization actions. | |
32b794c8 | 738 | |
5b42c035 AC |
739 | Push_Scope (Unit_Id); |
740 | Analyze (FM_Decl); | |
741 | Analyze (FM_Init); | |
742 | Pop_Scope; | |
32b794c8 | 743 | |
5b42c035 | 744 | -- Mark the master as servicing this specific designated type |
32b794c8 | 745 | |
5b42c035 | 746 | Set_Anonymous_Designated_Type (FM_Id, Desig_Typ); |
32b794c8 | 747 | |
5b42c035 AC |
748 | -- Include the anonymous master in the list of existing masters which |
749 | -- appear in this unit. This effectively creates a mapping between a | |
c9d2e84b GD |
750 | -- master and a designated type which in turn allows for the reuse of |
751 | -- masters on a per-unit basis. | |
32b794c8 | 752 | |
5b42c035 | 753 | All_FMs := Anonymous_Masters (Unit_Id); |
32b794c8 | 754 | |
5b42c035 AC |
755 | if No (All_FMs) then |
756 | All_FMs := New_Elmt_List; | |
757 | Set_Anonymous_Masters (Unit_Id, All_FMs); | |
758 | end if; | |
32b794c8 | 759 | |
5b42c035 | 760 | Prepend_Elmt (FM_Id, All_FMs); |
32b794c8 AC |
761 | |
762 | return FM_Id; | |
763 | end Create_Anonymous_Master; | |
764 | ||
5b42c035 AC |
765 | ------------------------------ |
766 | -- Current_Anonymous_Master -- | |
767 | ------------------------------ | |
32b794c8 | 768 | |
5b42c035 AC |
769 | function Current_Anonymous_Master |
770 | (Desig_Typ : Entity_Id; | |
771 | Unit_Id : Entity_Id) return Entity_Id | |
772 | is | |
773 | All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id); | |
774 | FM_Elmt : Elmt_Id; | |
775 | FM_Id : Entity_Id; | |
32b794c8 AC |
776 | |
777 | begin | |
5b42c035 AC |
778 | -- Inspect the list of anonymous masters declared within the unit |
779 | -- looking for an existing master which services the same designated | |
780 | -- type. | |
32b794c8 | 781 | |
5b42c035 AC |
782 | if Present (All_FMs) then |
783 | FM_Elmt := First_Elmt (All_FMs); | |
784 | while Present (FM_Elmt) loop | |
785 | FM_Id := Node (FM_Elmt); | |
32b794c8 | 786 | |
5b42c035 AC |
787 | -- The currect master services the same designated type. As a |
788 | -- result the master can be reused and associated with another | |
789 | -- anonymous access-to-controlled type. | |
32b794c8 | 790 | |
5b42c035 AC |
791 | if Anonymous_Designated_Type (FM_Id) = Desig_Typ then |
792 | return FM_Id; | |
793 | end if; | |
794 | ||
795 | Next_Elmt (FM_Elmt); | |
796 | end loop; | |
797 | end if; | |
798 | ||
799 | return Empty; | |
800 | end Current_Anonymous_Master; | |
32b794c8 AC |
801 | |
802 | -- Local variables | |
803 | ||
804 | Desig_Typ : Entity_Id; | |
805 | FM_Id : Entity_Id; | |
806 | Priv_View : Entity_Id; | |
807 | Unit_Decl : Node_Id; | |
808 | Unit_Id : Entity_Id; | |
809 | ||
810 | -- Start of processing for Build_Anonymous_Master | |
811 | ||
812 | begin | |
813 | -- Nothing to do if the circumstances do not allow for a finalization | |
814 | -- master. | |
815 | ||
816 | if not Allows_Finalization_Master (Ptr_Typ) then | |
817 | return; | |
818 | end if; | |
819 | ||
820 | Unit_Decl := Unit (Cunit (Current_Sem_Unit)); | |
5b42c035 | 821 | Unit_Id := Unique_Defining_Entity (Unit_Decl); |
32b794c8 AC |
822 | |
823 | -- The compilation unit is a package instantiation. In this case the | |
824 | -- anonymous master is associated with the package spec as both the | |
825 | -- spec and body appear at the same level. | |
826 | ||
827 | if Nkind (Unit_Decl) = N_Package_Body | |
828 | and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation | |
829 | then | |
830 | Unit_Id := Corresponding_Spec (Unit_Decl); | |
831 | Unit_Decl := Unit_Declaration_Node (Unit_Id); | |
832 | end if; | |
833 | ||
834 | -- Use the initial declaration of the designated type when it denotes | |
835 | -- the full view of an incomplete or private type. This ensures that | |
836 | -- types with one and two views are treated the same. | |
837 | ||
838 | Desig_Typ := Directly_Designated_Type (Ptr_Typ); | |
839 | Priv_View := Incomplete_Or_Partial_View (Desig_Typ); | |
840 | ||
841 | if Present (Priv_View) then | |
842 | Desig_Typ := Priv_View; | |
843 | end if; | |
844 | ||
5b42c035 AC |
845 | -- Determine whether the current semantic unit already has an anonymous |
846 | -- master which services the designated type. | |
32b794c8 | 847 | |
5b42c035 | 848 | FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id); |
32b794c8 | 849 | |
5b42c035 | 850 | -- If this is not the case, create a new master |
32b794c8 | 851 | |
5b42c035 | 852 | if No (FM_Id) then |
32b794c8 AC |
853 | FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl); |
854 | end if; | |
855 | ||
856 | Set_Finalization_Master (Ptr_Typ, FM_Id); | |
857 | end Build_Anonymous_Master; | |
858 | ||
70482933 RK |
859 | ---------------------------- |
860 | -- Build_Array_Deep_Procs -- | |
861 | ---------------------------- | |
862 | ||
863 | procedure Build_Array_Deep_Procs (Typ : Entity_Id) is | |
864 | begin | |
865 | Set_TSS (Typ, | |
cfae2bed AC |
866 | Make_Deep_Proc |
867 | (Prim => Initialize_Case, | |
868 | Typ => Typ, | |
869 | Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); | |
70482933 | 870 | |
51245e2d | 871 | if not Is_Limited_View (Typ) then |
70482933 | 872 | Set_TSS (Typ, |
cfae2bed AC |
873 | Make_Deep_Proc |
874 | (Prim => Adjust_Case, | |
875 | Typ => Typ, | |
876 | Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); | |
70482933 RK |
877 | end if; |
878 | ||
d2b4b3da AC |
879 | -- Do not generate Deep_Finalize and Finalize_Address if finalization is |
880 | -- suppressed since these routine will not be used. | |
70482933 | 881 | |
d2b4b3da | 882 | if not Restriction_Active (No_Finalization) then |
df3e68b1 | 883 | Set_TSS (Typ, |
2c1b72d7 | 884 | Make_Deep_Proc |
d2b4b3da | 885 | (Prim => Finalize_Case, |
2c1b72d7 | 886 | Typ => Typ, |
d2b4b3da AC |
887 | Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); |
888 | ||
94295b25 | 889 | -- Create TSS primitive Finalize_Address (unless CodePeer_Mode) |
d2b4b3da | 890 | |
89b6c83e AC |
891 | if not CodePeer_Mode then |
892 | Set_TSS (Typ, | |
893 | Make_Deep_Proc | |
894 | (Prim => Address_Case, | |
895 | Typ => Typ, | |
896 | Stmts => Make_Deep_Array_Body (Address_Case, Typ))); | |
897 | end if; | |
70482933 | 898 | end if; |
df3e68b1 | 899 | end Build_Array_Deep_Procs; |
70482933 | 900 | |
df3e68b1 HK |
901 | ------------------------------ |
902 | -- Build_Cleanup_Statements -- | |
903 | ------------------------------ | |
70482933 | 904 | |
36295779 AC |
905 | function Build_Cleanup_Statements |
906 | (N : Node_Id; | |
907 | Additional_Cleanup : List_Id) return List_Id | |
908 | is | |
df3e68b1 HK |
909 | Is_Asynchronous_Call : constant Boolean := |
910 | Nkind (N) = N_Block_Statement | |
911 | and then Is_Asynchronous_Call_Block (N); | |
912 | Is_Master : constant Boolean := | |
26e7e1a0 | 913 | Nkind (N) /= N_Entry_Body |
df3e68b1 HK |
914 | and then Is_Task_Master (N); |
915 | Is_Protected_Body : constant Boolean := | |
916 | Nkind (N) = N_Subprogram_Body | |
917 | and then Is_Protected_Subprogram_Body (N); | |
918 | Is_Task_Allocation : constant Boolean := | |
919 | Nkind (N) = N_Block_Statement | |
920 | and then Is_Task_Allocation_Block (N); | |
921 | Is_Task_Body : constant Boolean := | |
922 | Nkind (Original_Node (N)) = N_Task_Body; | |
2c1b72d7 | 923 | |
df3e68b1 HK |
924 | Loc : constant Source_Ptr := Sloc (N); |
925 | Stmts : constant List_Id := New_List; | |
70482933 RK |
926 | |
927 | begin | |
df3e68b1 HK |
928 | if Is_Task_Body then |
929 | if Restricted_Profile then | |
930 | Append_To (Stmts, | |
931 | Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); | |
932 | else | |
933 | Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task)); | |
934 | end if; | |
70482933 | 935 | |
df3e68b1 HK |
936 | elsif Is_Master then |
937 | if Restriction_Active (No_Task_Hierarchy) = False then | |
938 | Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master)); | |
939 | end if; | |
66713d62 | 940 | |
df3e68b1 HK |
941 | -- Add statements to unlock the protected object parameter and to |
942 | -- undefer abort. If the context is a protected procedure and the object | |
943 | -- has entries, call the entry service routine. | |
07fc65c4 | 944 | |
df3e68b1 | 945 | -- NOTE: The generated code references _object, a parameter to the |
886b5a18 | 946 | -- procedure. |
b603e37b | 947 | |
df3e68b1 HK |
948 | elsif Is_Protected_Body then |
949 | declare | |
950 | Spec : constant Node_Id := Parent (Corresponding_Spec (N)); | |
a6b13d32 | 951 | Conc_Typ : Entity_Id := Empty; |
df3e68b1 HK |
952 | Param : Node_Id; |
953 | Param_Typ : Entity_Id; | |
70482933 | 954 | |
df3e68b1 HK |
955 | begin |
956 | -- Find the _object parameter representing the protected object | |
07fc65c4 | 957 | |
df3e68b1 HK |
958 | Param := First (Parameter_Specifications (Spec)); |
959 | loop | |
960 | Param_Typ := Etype (Parameter_Type (Param)); | |
07fc65c4 | 961 | |
df3e68b1 HK |
962 | if Ekind (Param_Typ) = E_Record_Type then |
963 | Conc_Typ := Corresponding_Concurrent_Type (Param_Typ); | |
964 | end if; | |
70482933 | 965 | |
df3e68b1 HK |
966 | exit when No (Param) or else Present (Conc_Typ); |
967 | Next (Param); | |
968 | end loop; | |
70482933 | 969 | |
df3e68b1 | 970 | pragma Assert (Present (Param)); |
a6b13d32 | 971 | pragma Assert (Present (Conc_Typ)); |
70482933 | 972 | |
29077c18 | 973 | -- Historical note: In earlier versions of GNAT, there was code |
8b4230c8 AC |
974 | -- at this point to generate stuff to service entry queues. It is |
975 | -- now abstracted in Build_Protected_Subprogram_Call_Cleanup. | |
29077c18 AC |
976 | |
977 | Build_Protected_Subprogram_Call_Cleanup | |
978 | (Specification (N), Conc_Typ, Loc, Stmts); | |
df3e68b1 | 979 | end; |
fbf5a39b | 980 | |
df3e68b1 HK |
981 | -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated |
982 | -- tasks. Other unactivated tasks are completed by Complete_Task or | |
983 | -- Complete_Master. | |
fbf5a39b | 984 | |
df3e68b1 | 985 | -- NOTE: The generated code references _chain, a local object |
fbf5a39b | 986 | |
df3e68b1 | 987 | elsif Is_Task_Allocation then |
fbf5a39b | 988 | |
df3e68b1 HK |
989 | -- Generate: |
990 | -- Expunge_Unactivated_Tasks (_chain); | |
fbf5a39b | 991 | |
df3e68b1 HK |
992 | -- where _chain is the list of tasks created by the allocator but not |
993 | -- yet activated. This list will be empty unless the block completes | |
994 | -- abnormally. | |
fbf5a39b | 995 | |
df3e68b1 HK |
996 | Append_To (Stmts, |
997 | Make_Procedure_Call_Statement (Loc, | |
998 | Name => | |
e4494292 | 999 | New_Occurrence_Of |
2c1b72d7 | 1000 | (RTE (RE_Expunge_Unactivated_Tasks), Loc), |
df3e68b1 | 1001 | Parameter_Associations => New_List ( |
e4494292 | 1002 | New_Occurrence_Of (Activation_Chain_Entity (N), Loc)))); |
fbf5a39b | 1003 | |
df3e68b1 HK |
1004 | -- Attempt to cancel an asynchronous entry call whenever the block which |
1005 | -- contains the abortable part is exited. | |
fbf5a39b | 1006 | |
df3e68b1 | 1007 | -- NOTE: The generated code references Cnn, a local object |
fbf5a39b | 1008 | |
df3e68b1 HK |
1009 | elsif Is_Asynchronous_Call then |
1010 | declare | |
1011 | Cancel_Param : constant Entity_Id := | |
1012 | Entry_Cancel_Parameter (Entity (Identifier (N))); | |
fbf5a39b | 1013 | |
df3e68b1 HK |
1014 | begin |
1015 | -- If it is of type Communication_Block, this must be a protected | |
1016 | -- entry call. Generate: | |
1017 | ||
1018 | -- if Enqueued (Cancel_Param) then | |
1019 | -- Cancel_Protected_Entry_Call (Cancel_Param); | |
1020 | -- end if; | |
1021 | ||
1022 | if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then | |
1023 | Append_To (Stmts, | |
1024 | Make_If_Statement (Loc, | |
1025 | Condition => | |
1026 | Make_Function_Call (Loc, | |
2c1b72d7 | 1027 | Name => |
e4494292 | 1028 | New_Occurrence_Of (RTE (RE_Enqueued), Loc), |
df3e68b1 | 1029 | Parameter_Associations => New_List ( |
e4494292 | 1030 | New_Occurrence_Of (Cancel_Param, Loc))), |
fbf5a39b | 1031 | |
df3e68b1 HK |
1032 | Then_Statements => New_List ( |
1033 | Make_Procedure_Call_Statement (Loc, | |
1034 | Name => | |
e4494292 | 1035 | New_Occurrence_Of |
2c1b72d7 | 1036 | (RTE (RE_Cancel_Protected_Entry_Call), Loc), |
df3e68b1 | 1037 | Parameter_Associations => New_List ( |
e4494292 | 1038 | New_Occurrence_Of (Cancel_Param, Loc)))))); |
fbf5a39b | 1039 | |
df3e68b1 HK |
1040 | -- Asynchronous delay, generate: |
1041 | -- Cancel_Async_Delay (Cancel_Param); | |
fbf5a39b | 1042 | |
df3e68b1 HK |
1043 | elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then |
1044 | Append_To (Stmts, | |
1045 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 1046 | Name => |
e4494292 | 1047 | New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc), |
df3e68b1 HK |
1048 | Parameter_Associations => New_List ( |
1049 | Make_Attribute_Reference (Loc, | |
2c1b72d7 | 1050 | Prefix => |
e4494292 | 1051 | New_Occurrence_Of (Cancel_Param, Loc), |
df3e68b1 HK |
1052 | Attribute_Name => Name_Unchecked_Access)))); |
1053 | ||
1054 | -- Task entry call, generate: | |
1055 | -- Cancel_Task_Entry_Call (Cancel_Param); | |
1056 | ||
1057 | else | |
1058 | Append_To (Stmts, | |
1059 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 1060 | Name => |
e4494292 | 1061 | New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc), |
df3e68b1 | 1062 | Parameter_Associations => New_List ( |
e4494292 | 1063 | New_Occurrence_Of (Cancel_Param, Loc)))); |
df3e68b1 HK |
1064 | end if; |
1065 | end; | |
fbf5a39b AC |
1066 | end if; |
1067 | ||
36295779 | 1068 | Append_List_To (Stmts, Additional_Cleanup); |
df3e68b1 HK |
1069 | return Stmts; |
1070 | end Build_Cleanup_Statements; | |
fbf5a39b | 1071 | |
df3e68b1 HK |
1072 | ----------------------------- |
1073 | -- Build_Controlling_Procs -- | |
1074 | ----------------------------- | |
fbf5a39b | 1075 | |
df3e68b1 HK |
1076 | procedure Build_Controlling_Procs (Typ : Entity_Id) is |
1077 | begin | |
1078 | if Is_Array_Type (Typ) then | |
1079 | Build_Array_Deep_Procs (Typ); | |
df3e68b1 HK |
1080 | else pragma Assert (Is_Record_Type (Typ)); |
1081 | Build_Record_Deep_Procs (Typ); | |
1082 | end if; | |
1083 | end Build_Controlling_Procs; | |
fbf5a39b | 1084 | |
df3e68b1 HK |
1085 | ----------------------------- |
1086 | -- Build_Exception_Handler -- | |
1087 | ----------------------------- | |
fbf5a39b | 1088 | |
df3e68b1 | 1089 | function Build_Exception_Handler |
36b8f95f | 1090 | (Data : Finalization_Exception_Data; |
df3e68b1 HK |
1091 | For_Library : Boolean := False) return Node_Id |
1092 | is | |
1093 | Actuals : List_Id; | |
1094 | Proc_To_Call : Entity_Id; | |
e5a22243 | 1095 | Except : Node_Id; |
23adb371 | 1096 | Stmts : List_Id; |
fbf5a39b | 1097 | |
df3e68b1 | 1098 | begin |
36b8f95f | 1099 | pragma Assert (Present (Data.Raised_Id)); |
fbf5a39b | 1100 | |
23adb371 | 1101 | if Exception_Extra_Info |
799d0e05 | 1102 | or else (For_Library and not Restricted_Profile) |
23adb371 AC |
1103 | then |
1104 | if Exception_Extra_Info then | |
799d0e05 | 1105 | |
23adb371 | 1106 | -- Generate: |
fbf5a39b | 1107 | |
23adb371 | 1108 | -- Get_Current_Excep.all |
e5a22243 | 1109 | |
23adb371 AC |
1110 | Except := |
1111 | Make_Function_Call (Data.Loc, | |
1112 | Name => | |
1113 | Make_Explicit_Dereference (Data.Loc, | |
1114 | Prefix => | |
e4494292 | 1115 | New_Occurrence_Of |
799d0e05 AC |
1116 | (RTE (RE_Get_Current_Excep), Data.Loc))); |
1117 | ||
23adb371 AC |
1118 | else |
1119 | -- Generate: | |
e5a22243 | 1120 | |
23adb371 AC |
1121 | -- null |
1122 | ||
1123 | Except := Make_Null (Data.Loc); | |
1124 | end if; | |
1125 | ||
1126 | if For_Library and then not Restricted_Profile then | |
1127 | Proc_To_Call := RTE (RE_Save_Library_Occurrence); | |
1128 | Actuals := New_List (Except); | |
799d0e05 | 1129 | |
23adb371 AC |
1130 | else |
1131 | Proc_To_Call := RTE (RE_Save_Occurrence); | |
1132 | ||
1133 | -- The dereference occurs only when Exception_Extra_Info is true, | |
1134 | -- and therefore Except is not null. | |
1135 | ||
799d0e05 AC |
1136 | Actuals := |
1137 | New_List ( | |
e4494292 | 1138 | New_Occurrence_Of (Data.E_Id, Data.Loc), |
799d0e05 | 1139 | Make_Explicit_Dereference (Data.Loc, Except)); |
23adb371 AC |
1140 | end if; |
1141 | ||
1142 | -- Generate: | |
1143 | ||
1144 | -- when others => | |
1145 | -- if not Raised_Id then | |
1146 | -- Raised_Id := True; | |
1147 | ||
1148 | -- Save_Occurrence (E_Id, Get_Current_Excep.all.all); | |
1149 | -- or | |
1150 | -- Save_Library_Occurrence (Get_Current_Excep.all); | |
1151 | -- end if; | |
1152 | ||
1153 | Stmts := | |
1154 | New_List ( | |
1155 | Make_If_Statement (Data.Loc, | |
1156 | Condition => | |
1157 | Make_Op_Not (Data.Loc, | |
e4494292 | 1158 | Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)), |
23adb371 AC |
1159 | |
1160 | Then_Statements => New_List ( | |
1161 | Make_Assignment_Statement (Data.Loc, | |
e4494292 RD |
1162 | Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc), |
1163 | Expression => New_Occurrence_Of (Standard_True, Data.Loc)), | |
23adb371 AC |
1164 | |
1165 | Make_Procedure_Call_Statement (Data.Loc, | |
1166 | Name => | |
e4494292 | 1167 | New_Occurrence_Of (Proc_To_Call, Data.Loc), |
23adb371 AC |
1168 | Parameter_Associations => Actuals)))); |
1169 | ||
1170 | else | |
1171 | -- Generate: | |
1172 | ||
1173 | -- Raised_Id := True; | |
1174 | ||
1175 | Stmts := New_List ( | |
1176 | Make_Assignment_Statement (Data.Loc, | |
e4494292 RD |
1177 | Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc), |
1178 | Expression => New_Occurrence_Of (Standard_True, Data.Loc))); | |
df3e68b1 | 1179 | end if; |
fbf5a39b | 1180 | |
df3e68b1 | 1181 | -- Generate: |
e5a22243 | 1182 | |
df3e68b1 | 1183 | -- when others => |
fbf5a39b | 1184 | |
df3e68b1 | 1185 | return |
36b8f95f | 1186 | Make_Exception_Handler (Data.Loc, |
23adb371 AC |
1187 | Exception_Choices => New_List (Make_Others_Choice (Data.Loc)), |
1188 | Statements => Stmts); | |
df3e68b1 | 1189 | end Build_Exception_Handler; |
fbf5a39b | 1190 | |
d3f70b35 AC |
1191 | ------------------------------- |
1192 | -- Build_Finalization_Master -- | |
1193 | ------------------------------- | |
fbf5a39b | 1194 | |
d3f70b35 | 1195 | procedure Build_Finalization_Master |
760804f3 | 1196 | (Typ : Entity_Id; |
8434cfc7 | 1197 | For_Lib_Level : Boolean := False; |
760804f3 AC |
1198 | For_Private : Boolean := False; |
1199 | Context_Scope : Entity_Id := Empty; | |
1200 | Insertion_Node : Node_Id := Empty) | |
df3e68b1 | 1201 | is |
760804f3 AC |
1202 | procedure Add_Pending_Access_Type |
1203 | (Typ : Entity_Id; | |
1204 | Ptr_Typ : Entity_Id); | |
1205 | -- Add access type Ptr_Typ to the pending access type list for type Typ | |
1206 | ||
760804f3 AC |
1207 | ----------------------------- |
1208 | -- Add_Pending_Access_Type -- | |
1209 | ----------------------------- | |
1210 | ||
1211 | procedure Add_Pending_Access_Type | |
1212 | (Typ : Entity_Id; | |
1213 | Ptr_Typ : Entity_Id) | |
1214 | is | |
1215 | List : Elist_Id; | |
1216 | ||
1217 | begin | |
1218 | if Present (Pending_Access_Types (Typ)) then | |
1219 | List := Pending_Access_Types (Typ); | |
1220 | else | |
1221 | List := New_Elmt_List; | |
1222 | Set_Pending_Access_Types (Typ, List); | |
1223 | end if; | |
1224 | ||
1225 | Prepend_Elmt (Ptr_Typ, List); | |
1226 | end Add_Pending_Access_Type; | |
1227 | ||
8a5e4b2a AC |
1228 | -- Local variables |
1229 | ||
760804f3 | 1230 | Desig_Typ : constant Entity_Id := Designated_Type (Typ); |
8a5e4b2a AC |
1231 | |
1232 | Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ)); | |
1233 | -- A finalization master created for a named access type is associated | |
1234 | -- with the full view (if applicable) as a consequence of freezing. The | |
1235 | -- full view criteria does not apply to anonymous access types because | |
1236 | -- those cannot have a private and a full view. | |
1237 | ||
d3f70b35 | 1238 | -- Start of processing for Build_Finalization_Master |
fbf5a39b | 1239 | |
df3e68b1 | 1240 | begin |
32b794c8 AC |
1241 | -- Nothing to do if the circumstances do not allow for a finalization |
1242 | -- master. | |
f553e7bc | 1243 | |
32b794c8 | 1244 | if not Allows_Finalization_Master (Typ) then |
ca5af305 AC |
1245 | return; |
1246 | ||
f553e7bc | 1247 | -- Various machinery such as freezing may have already created a |
d3f70b35 | 1248 | -- finalization master. |
f553e7bc | 1249 | |
ca5af305 | 1250 | elsif Present (Finalization_Master (Ptr_Typ)) then |
df3e68b1 | 1251 | return; |
fbf5a39b | 1252 | end if; |
fbf5a39b | 1253 | |
df3e68b1 | 1254 | declare |
760804f3 | 1255 | Actions : constant List_Id := New_List; |
ca5af305 | 1256 | Loc : constant Source_Ptr := Sloc (Ptr_Typ); |
d3f70b35 AC |
1257 | Fin_Mas_Id : Entity_Id; |
1258 | Pool_Id : Entity_Id; | |
fbf5a39b | 1259 | |
df3e68b1 | 1260 | begin |
d3f70b35 AC |
1261 | -- Source access types use fixed master names since the master is |
1262 | -- inserted in the same source unit only once. The only exception to | |
1263 | -- this are instances using the same access type as generic actual. | |
df3e68b1 | 1264 | |
36295779 | 1265 | if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then |
d3f70b35 | 1266 | Fin_Mas_Id := |
df3e68b1 | 1267 | Make_Defining_Identifier (Loc, |
d3f70b35 AC |
1268 | Chars => New_External_Name (Chars (Ptr_Typ), "FM")); |
1269 | ||
1270 | -- Internally generated access types use temporaries as their names | |
1271 | -- due to possible collision with identical names coming from other | |
1272 | -- packages. | |
1273 | ||
df3e68b1 | 1274 | else |
d3f70b35 | 1275 | Fin_Mas_Id := Make_Temporary (Loc, 'F'); |
df3e68b1 | 1276 | end if; |
fbf5a39b | 1277 | |
760804f3 AC |
1278 | Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
1279 | ||
1280 | -- Generate: | |
1281 | -- <Ptr_Typ>FM : aliased Finalization_Master; | |
1282 | ||
df3e68b1 HK |
1283 | Append_To (Actions, |
1284 | Make_Object_Declaration (Loc, | |
d3f70b35 AC |
1285 | Defining_Identifier => Fin_Mas_Id, |
1286 | Aliased_Present => True, | |
cfae2bed | 1287 | Object_Definition => |
e4494292 | 1288 | New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); |
fbf5a39b | 1289 | |
bbf14e13 AC |
1290 | if Debug_Generated_Code then |
1291 | Set_Debug_Info_Needed (Fin_Mas_Id); | |
1292 | end if; | |
1293 | ||
760804f3 | 1294 | -- Set the associated pool and primitive Finalize_Address of the new |
535a8637 | 1295 | -- finalization master. |
fbf5a39b | 1296 | |
535a8637 | 1297 | -- The access type has a user-defined storage pool, use it |
fbf5a39b | 1298 | |
535a8637 AC |
1299 | if Present (Associated_Storage_Pool (Ptr_Typ)) then |
1300 | Pool_Id := Associated_Storage_Pool (Ptr_Typ); | |
fbf5a39b | 1301 | |
535a8637 | 1302 | -- Otherwise the default choice is the global storage pool |
df3e68b1 | 1303 | |
535a8637 AC |
1304 | else |
1305 | Pool_Id := RTE (RE_Global_Pool_Object); | |
1306 | Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); | |
1307 | end if; | |
deb8dacc | 1308 | |
535a8637 AC |
1309 | -- Generate: |
1310 | -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access); | |
deb8dacc | 1311 | |
535a8637 AC |
1312 | Append_To (Actions, |
1313 | Make_Procedure_Call_Statement (Loc, | |
1314 | Name => | |
1315 | New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc), | |
1316 | Parameter_Associations => New_List ( | |
1317 | New_Occurrence_Of (Fin_Mas_Id, Loc), | |
1318 | Make_Attribute_Reference (Loc, | |
1319 | Prefix => New_Occurrence_Of (Pool_Id, Loc), | |
1320 | Attribute_Name => Name_Unrestricted_Access)))); | |
760804f3 | 1321 | |
535a8637 AC |
1322 | -- Finalize_Address is not generated in CodePeer mode because the |
1323 | -- body contains address arithmetic. Skip this step. | |
760804f3 | 1324 | |
535a8637 AC |
1325 | if CodePeer_Mode then |
1326 | null; | |
760804f3 | 1327 | |
535a8637 AC |
1328 | -- Associate the Finalize_Address primitive of the designated type |
1329 | -- with the finalization master of the access type. The designated | |
1330 | -- type must be forzen as Finalize_Address is generated when the | |
1331 | -- freeze node is expanded. | |
760804f3 | 1332 | |
535a8637 AC |
1333 | elsif Is_Frozen (Desig_Typ) |
1334 | and then Present (Finalize_Address (Desig_Typ)) | |
760804f3 | 1335 | |
535a8637 AC |
1336 | -- The finalization master of an anonymous access type may need |
1337 | -- to be inserted in a specific place in the tree. For instance: | |
760804f3 | 1338 | |
535a8637 | 1339 | -- type Comp_Typ; |
760804f3 | 1340 | |
535a8637 | 1341 | -- <finalization master of "access Comp_Typ"> |
760804f3 | 1342 | |
535a8637 AC |
1343 | -- type Rec_Typ is record |
1344 | -- Comp : access Comp_Typ; | |
1345 | -- end record; | |
760804f3 | 1346 | |
535a8637 AC |
1347 | -- <freeze node for Comp_Typ> |
1348 | -- <freeze node for Rec_Typ> | |
760804f3 | 1349 | |
535a8637 AC |
1350 | -- Due to this oddity, the anonymous access type is stored for |
1351 | -- later processing (see below). | |
760804f3 | 1352 | |
535a8637 AC |
1353 | and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type |
1354 | then | |
1355 | -- Generate: | |
1356 | -- Set_Finalize_Address | |
1357 | -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); | |
760804f3 | 1358 | |
535a8637 AC |
1359 | Append_To (Actions, |
1360 | Make_Set_Finalize_Address_Call | |
1361 | (Loc => Loc, | |
1362 | Ptr_Typ => Ptr_Typ)); | |
760804f3 | 1363 | |
535a8637 AC |
1364 | -- Otherwise the designated type is either anonymous access or a |
1365 | -- Taft-amendment type and has not been frozen. Store the access | |
1366 | -- type for later processing (see Freeze_Type). | |
760804f3 | 1367 | |
535a8637 AC |
1368 | else |
1369 | Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); | |
deb8dacc | 1370 | end if; |
df3e68b1 | 1371 | |
32b794c8 AC |
1372 | -- A finalization master created for an access designating a type |
1373 | -- with private components is inserted before a context-dependent | |
1374 | -- node. | |
df3e68b1 | 1375 | |
32b794c8 | 1376 | if For_Private then |
df3e68b1 | 1377 | |
760804f3 AC |
1378 | -- At this point both the scope of the context and the insertion |
1379 | -- mode must be known. | |
1380 | ||
1381 | pragma Assert (Present (Context_Scope)); | |
1382 | pragma Assert (Present (Insertion_Node)); | |
1383 | ||
1384 | Push_Scope (Context_Scope); | |
df3e68b1 HK |
1385 | |
1386 | -- Treat use clauses as declarations and insert directly in front | |
1387 | -- of them. | |
1388 | ||
4a08c95c AC |
1389 | if Nkind (Insertion_Node) in |
1390 | N_Use_Package_Clause | N_Use_Type_Clause | |
df3e68b1 | 1391 | then |
760804f3 | 1392 | Insert_List_Before_And_Analyze (Insertion_Node, Actions); |
fbf5a39b | 1393 | else |
760804f3 | 1394 | Insert_Actions (Insertion_Node, Actions); |
fbf5a39b | 1395 | end if; |
df3e68b1 HK |
1396 | |
1397 | Pop_Scope; | |
1398 | ||
8434cfc7 AC |
1399 | -- The finalization master belongs to an access result type related |
1400 | -- to a build-in-place function call used to initialize a library | |
1401 | -- level object. The master must be inserted in front of the access | |
1402 | -- result type declaration denoted by Insertion_Node. | |
1403 | ||
1404 | elsif For_Lib_Level then | |
1405 | pragma Assert (Present (Insertion_Node)); | |
1406 | Insert_Actions (Insertion_Node, Actions); | |
1407 | ||
760804f3 AC |
1408 | -- Otherwise the finalization master and its initialization become a |
1409 | -- part of the freeze node. | |
df3e68b1 HK |
1410 | |
1411 | else | |
760804f3 | 1412 | Append_Freeze_Actions (Ptr_Typ, Actions); |
fbf5a39b | 1413 | end if; |
a1023434 JS |
1414 | |
1415 | Analyze_List (Actions); | |
1416 | ||
1417 | -- When the type the finalization master is being generated for was | |
1418 | -- created to store a 'Old object, then mark it as such so its | |
1419 | -- finalization can be delayed until after postconditions have been | |
1420 | -- checked. | |
1421 | ||
1422 | if Stores_Attribute_Old_Prefix (Ptr_Typ) then | |
1423 | Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id); | |
1424 | end if; | |
df3e68b1 | 1425 | end; |
d3f70b35 | 1426 | end Build_Finalization_Master; |
fbf5a39b | 1427 | |
a1023434 JS |
1428 | ---------------------------- |
1429 | -- Build_Finalizer_Helper -- | |
1430 | ---------------------------- | |
afe4375b | 1431 | |
a1023434 | 1432 | procedure Build_Finalizer_Helper |
c0ffadd6 JS |
1433 | (N : Node_Id; |
1434 | Clean_Stmts : List_Id; | |
1435 | Mark_Id : Entity_Id; | |
1436 | Top_Decls : List_Id; | |
1437 | Defer_Abort : Boolean; | |
a1023434 JS |
1438 | Fin_Id : out Entity_Id; |
1439 | Finalize_Old_Only : Boolean) | |
df3e68b1 HK |
1440 | is |
1441 | Acts_As_Clean : constant Boolean := | |
1442 | Present (Mark_Id) | |
1443 | or else | |
1444 | (Present (Clean_Stmts) | |
cfae2bed | 1445 | and then Is_Non_Empty_List (Clean_Stmts)); |
640ad9c2 | 1446 | |
df3e68b1 HK |
1447 | For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body; |
1448 | For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration; | |
1449 | For_Package : constant Boolean := | |
1450 | For_Package_Body or else For_Package_Spec; | |
1451 | Loc : constant Source_Ptr := Sloc (N); | |
1452 | ||
1453 | -- NOTE: Local variable declarations are conservative and do not create | |
1454 | -- structures right from the start. Entities and lists are created once | |
1455 | -- it has been established that N has at least one controlled object. | |
1456 | ||
1457 | Components_Built : Boolean := False; | |
1458 | -- A flag used to avoid double initialization of entities and lists. If | |
1459 | -- the flag is set then the following variables have been initialized: | |
df3e68b1 | 1460 | -- Counter_Id |
df3e68b1 HK |
1461 | -- Finalizer_Decls |
1462 | -- Finalizer_Stmts | |
1463 | -- Jump_Alts | |
df3e68b1 HK |
1464 | |
1465 | Counter_Id : Entity_Id := Empty; | |
16e764a7 | 1466 | Counter_Val : Nat := 0; |
df3e68b1 HK |
1467 | -- Name and value of the state counter |
1468 | ||
1469 | Decls : List_Id := No_List; | |
1470 | -- Declarative region of N (if available). If N is a package declaration | |
1471 | -- Decls denotes the visible declarations. | |
1472 | ||
36b8f95f AC |
1473 | Finalizer_Data : Finalization_Exception_Data; |
1474 | -- Data for the exception | |
df3e68b1 HK |
1475 | |
1476 | Finalizer_Decls : List_Id := No_List; | |
1477 | -- Local variable declarations. This list holds the label declarations | |
1478 | -- of all jump block alternatives as well as the declaration of the | |
7f37fff1 | 1479 | -- local exception occurrence and the raised flag: |
df3e68b1 HK |
1480 | -- E : Exception_Occurrence; |
1481 | -- Raised : Boolean := False; | |
1482 | -- L<counter value> : label; | |
1483 | ||
1484 | Finalizer_Insert_Nod : Node_Id := Empty; | |
1485 | -- Insertion point for the finalizer body. Depending on the context | |
1486 | -- (Nkind of N) and the individual grouping of controlled objects, this | |
1487 | -- node may denote a package declaration or body, package instantiation, | |
1488 | -- block statement or a counter update statement. | |
1489 | ||
1490 | Finalizer_Stmts : List_Id := No_List; | |
1491 | -- The statement list of the finalizer body. It contains the following: | |
1492 | -- | |
1493 | -- Abort_Defer; -- Added if abort is allowed | |
1494 | -- <call to Prev_At_End> -- Added if exists | |
1495 | -- <cleanup statements> -- Added if Acts_As_Clean | |
1496 | -- <jump block> -- Added if Has_Ctrl_Objs | |
1497 | -- <finalization statements> -- Added if Has_Ctrl_Objs | |
1498 | -- <stack release> -- Added if Mark_Id exists | |
1499 | -- Abort_Undefer; -- Added if abort is allowed | |
1500 | ||
1501 | Has_Ctrl_Objs : Boolean := False; | |
1502 | -- A general flag which denotes whether N has at least one controlled | |
1503 | -- object. | |
1504 | ||
26e7e1a0 | 1505 | Has_Tagged_Types : Boolean := False; |
0319cacc AC |
1506 | -- A general flag which indicates whether N has at least one library- |
1507 | -- level tagged type declaration. | |
26e7e1a0 | 1508 | |
df3e68b1 HK |
1509 | HSS : Node_Id := Empty; |
1510 | -- The sequence of statements of N (if available) | |
1511 | ||
1512 | Jump_Alts : List_Id := No_List; | |
1513 | -- Jump block alternatives. Depending on the value of the state counter, | |
d34cd274 | 1514 | -- the control flow jumps to a sequence of finalization statements. This |
df3e68b1 HK |
1515 | -- list contains the following: |
1516 | -- | |
1517 | -- when <counter value> => | |
1518 | -- goto L<counter value>; | |
1519 | ||
1520 | Jump_Block_Insert_Nod : Node_Id := Empty; | |
1521 | -- Specific point in the finalizer statements where the jump block is | |
1522 | -- inserted. | |
1523 | ||
1524 | Last_Top_Level_Ctrl_Construct : Node_Id := Empty; | |
1525 | -- The last controlled construct encountered when processing the top | |
1526 | -- level lists of N. This can be a nested package, an instantiation or | |
1527 | -- an object declaration. | |
1528 | ||
1529 | Prev_At_End : Entity_Id := Empty; | |
1530 | -- The previous at end procedure of the handled statements block of N | |
1531 | ||
1532 | Priv_Decls : List_Id := No_List; | |
1533 | -- The private declarations of N if N is a package declaration | |
1534 | ||
df3e68b1 HK |
1535 | Spec_Id : Entity_Id := Empty; |
1536 | Spec_Decls : List_Id := Top_Decls; | |
1537 | Stmts : List_Id := No_List; | |
1538 | ||
26e7e1a0 AC |
1539 | Tagged_Type_Stmts : List_Id := No_List; |
1540 | -- Contains calls to Ada.Tags.Unregister_Tag for all library-level | |
1541 | -- tagged types found in N. | |
1542 | ||
df3e68b1 HK |
1543 | ----------------------- |
1544 | -- Local subprograms -- | |
1545 | ----------------------- | |
1546 | ||
1547 | procedure Build_Components; | |
1548 | -- Create all entites and initialize all lists used in the creation of | |
1549 | -- the finalizer. | |
1550 | ||
1551 | procedure Create_Finalizer; | |
1552 | -- Create the spec and body of the finalizer and insert them in the | |
1553 | -- proper place in the tree depending on the context. | |
1554 | ||
213c9dc7 AC |
1555 | function New_Finalizer_Name |
1556 | (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id; | |
1557 | -- Create a fully qualified name of a package spec or body finalizer. | |
1558 | -- The generated name is of the form: xx__yy__finalize_[spec|body]. | |
1559 | ||
df3e68b1 HK |
1560 | procedure Process_Declarations |
1561 | (Decls : List_Id; | |
1562 | Preprocess : Boolean := False; | |
1563 | Top_Level : Boolean := False); | |
1564 | -- Inspect a list of declarations or statements which may contain | |
1565 | -- objects that need finalization. When flag Preprocess is set, the | |
1566 | -- routine will simply count the total number of controlled objects in | |
213c9dc7 AC |
1567 | -- Decls and set Counter_Val accordingly. Top_Level is only relevant |
1568 | -- when Preprocess is set and if True, the processing is performed for | |
f46faa08 | 1569 | -- objects in nested package declarations or instances. |
df3e68b1 HK |
1570 | |
1571 | procedure Process_Object_Declaration | |
1572 | (Decl : Node_Id; | |
1573 | Has_No_Init : Boolean := False; | |
1574 | Is_Protected : Boolean := False); | |
1575 | -- Generate all the machinery associated with the finalization of a | |
1576 | -- single object. Flag Has_No_Init is used to denote certain contexts | |
1577 | -- where Decl does not have initialization call(s). Flag Is_Protected | |
1578 | -- is set when Decl denotes a simple protected object. | |
1579 | ||
26e7e1a0 AC |
1580 | procedure Process_Tagged_Type_Declaration (Decl : Node_Id); |
1581 | -- Generate all the code necessary to unregister the external tag of a | |
1582 | -- tagged type. | |
1583 | ||
df3e68b1 HK |
1584 | ---------------------- |
1585 | -- Build_Components -- | |
1586 | ---------------------- | |
1587 | ||
1588 | procedure Build_Components is | |
1589 | Counter_Decl : Node_Id; | |
1590 | Counter_Typ : Entity_Id; | |
1591 | Counter_Typ_Decl : Node_Id; | |
afe4375b | 1592 | |
df3e68b1 HK |
1593 | begin |
1594 | pragma Assert (Present (Decls)); | |
70482933 | 1595 | |
df3e68b1 HK |
1596 | -- This routine might be invoked several times when dealing with |
1597 | -- constructs that have two lists (either two declarative regions | |
1598 | -- or declarations and statements). Avoid double initialization. | |
70482933 | 1599 | |
df3e68b1 HK |
1600 | if Components_Built then |
1601 | return; | |
1602 | end if; | |
70482933 | 1603 | |
df3e68b1 | 1604 | Components_Built := True; |
70482933 | 1605 | |
df3e68b1 | 1606 | if Has_Ctrl_Objs then |
70482933 | 1607 | |
df3e68b1 HK |
1608 | -- Create entities for the counter, its type, the local exception |
1609 | -- and the raised flag. | |
70482933 | 1610 | |
df3e68b1 HK |
1611 | Counter_Id := Make_Temporary (Loc, 'C'); |
1612 | Counter_Typ := Make_Temporary (Loc, 'T'); | |
70482933 | 1613 | |
36b8f95f AC |
1614 | Finalizer_Decls := New_List; |
1615 | ||
2d1debf8 AC |
1616 | Build_Object_Declarations |
1617 | (Finalizer_Data, Finalizer_Decls, Loc, For_Package); | |
70482933 | 1618 | |
df3e68b1 HK |
1619 | -- Since the total number of controlled objects is always known, |
1620 | -- build a subtype of Natural with precise bounds. This allows | |
1621 | -- the backend to optimize the case statement. Generate: | |
1622 | -- | |
1623 | -- subtype Tnn is Natural range 0 .. Counter_Val; | |
1624 | ||
1625 | Counter_Typ_Decl := | |
1626 | Make_Subtype_Declaration (Loc, | |
1627 | Defining_Identifier => Counter_Typ, | |
cfae2bed | 1628 | Subtype_Indication => |
df3e68b1 | 1629 | Make_Subtype_Indication (Loc, |
e4494292 | 1630 | Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), |
cfae2bed | 1631 | Constraint => |
df3e68b1 HK |
1632 | Make_Range_Constraint (Loc, |
1633 | Range_Expression => | |
1634 | Make_Range (Loc, | |
cfae2bed | 1635 | Low_Bound => |
df3e68b1 HK |
1636 | Make_Integer_Literal (Loc, Uint_0), |
1637 | High_Bound => | |
1638 | Make_Integer_Literal (Loc, Counter_Val))))); | |
1639 | ||
1640 | -- Generate the declaration of the counter itself: | |
1641 | -- | |
1642 | -- Counter : Integer := 0; | |
1643 | ||
1644 | Counter_Decl := | |
1645 | Make_Object_Declaration (Loc, | |
1646 | Defining_Identifier => Counter_Id, | |
e4494292 | 1647 | Object_Definition => New_Occurrence_Of (Counter_Typ, Loc), |
cfae2bed | 1648 | Expression => Make_Integer_Literal (Loc, 0)); |
df3e68b1 HK |
1649 | |
1650 | -- Set the type of the counter explicitly to prevent errors when | |
1651 | -- examining object declarations later on. | |
1652 | ||
1653 | Set_Etype (Counter_Id, Counter_Typ); | |
1654 | ||
bbf14e13 AC |
1655 | if Debug_Generated_Code then |
1656 | Set_Debug_Info_Needed (Counter_Id); | |
1657 | end if; | |
1658 | ||
df3e68b1 HK |
1659 | -- The counter and its type are inserted before the source |
1660 | -- declarations of N. | |
1661 | ||
1662 | Prepend_To (Decls, Counter_Decl); | |
1663 | Prepend_To (Decls, Counter_Typ_Decl); | |
1664 | ||
75b87c16 | 1665 | -- The counter and its associated type must be manually analyzed |
df3e68b1 HK |
1666 | -- since N has already been analyzed. Use the scope of the spec |
1667 | -- when inserting in a package. | |
1668 | ||
1669 | if For_Package then | |
1670 | Push_Scope (Spec_Id); | |
1671 | Analyze (Counter_Typ_Decl); | |
1672 | Analyze (Counter_Decl); | |
1673 | Pop_Scope; | |
70482933 | 1674 | |
df3e68b1 HK |
1675 | else |
1676 | Analyze (Counter_Typ_Decl); | |
1677 | Analyze (Counter_Decl); | |
70482933 | 1678 | end if; |
df3e68b1 | 1679 | |
df3e68b1 | 1680 | Jump_Alts := New_List; |
70482933 RK |
1681 | end if; |
1682 | ||
40c21e91 PMR |
1683 | -- If the context requires additional cleanup, the finalization |
1684 | -- machinery is added after the cleanup code. | |
70482933 | 1685 | |
df3e68b1 HK |
1686 | if Acts_As_Clean then |
1687 | Finalizer_Stmts := Clean_Stmts; | |
1688 | Jump_Block_Insert_Nod := Last (Finalizer_Stmts); | |
1689 | else | |
1690 | Finalizer_Stmts := New_List; | |
1691 | end if; | |
26e7e1a0 AC |
1692 | |
1693 | if Has_Tagged_Types then | |
1694 | Tagged_Type_Stmts := New_List; | |
1695 | end if; | |
df3e68b1 HK |
1696 | end Build_Components; |
1697 | ||
1698 | ---------------------- | |
1699 | -- Create_Finalizer -- | |
1700 | ---------------------- | |
1701 | ||
1702 | procedure Create_Finalizer is | |
7bf911b5 HK |
1703 | Body_Id : Entity_Id; |
1704 | Fin_Body : Node_Id; | |
1705 | Fin_Spec : Node_Id; | |
1706 | Jump_Block : Node_Id; | |
1707 | Label : Node_Id; | |
1708 | Label_Id : Entity_Id; | |
1709 | ||
df3e68b1 HK |
1710 | begin |
1711 | -- Step 1: Creation of the finalizer name | |
70482933 | 1712 | |
df3e68b1 | 1713 | -- Packages must use a distinct name for their finalizers since the |
cfae2bed AC |
1714 | -- binder will have to generate calls to them by name. The name is |
1715 | -- of the following form: | |
70482933 | 1716 | |
cfae2bed | 1717 | -- xx__yy__finalize_[spec|body] |
dbe13a37 | 1718 | |
cfae2bed | 1719 | if For_Package then |
213c9dc7 AC |
1720 | Fin_Id := Make_Defining_Identifier |
1721 | (Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec)); | |
cfae2bed AC |
1722 | Set_Has_Qualified_Name (Fin_Id); |
1723 | Set_Has_Fully_Qualified_Name (Fin_Id); | |
70482933 | 1724 | |
df3e68b1 | 1725 | -- The default name is _finalizer |
70482933 | 1726 | |
df3e68b1 | 1727 | else |
a1023434 JS |
1728 | -- Generation of a finalization procedure exclusively for 'Old |
1729 | -- interally generated constants requires different name since | |
1730 | -- there will need to be multiple finalization routines in the | |
1731 | -- same scope. See Build_Finalizer for details. | |
1732 | ||
1733 | if Finalize_Old_Only then | |
1734 | Fin_Id := | |
1735 | Make_Defining_Identifier (Loc, | |
1736 | Chars => New_External_Name (Name_uFinalizer_Old)); | |
1737 | else | |
1738 | Fin_Id := | |
1739 | Make_Defining_Identifier (Loc, | |
1740 | Chars => New_External_Name (Name_uFinalizer)); | |
1741 | end if; | |
31af8899 AC |
1742 | |
1743 | -- The visibility semantics of AT_END handlers force a strange | |
1744 | -- separation of spec and body for stack-related finalizers: | |
1745 | ||
1746 | -- declare : Enclosing_Scope | |
1747 | -- procedure _finalizer; | |
1748 | -- begin | |
1749 | -- <controlled objects> | |
1750 | -- procedure _finalizer is | |
1751 | -- ... | |
1752 | -- at end | |
1753 | -- _finalizer; | |
1754 | -- end; | |
1755 | ||
1756 | -- Both spec and body are within the same construct and scope, but | |
1757 | -- the body is part of the handled sequence of statements. This | |
1758 | -- placement confuses the elaboration mechanism on targets where | |
1759 | -- AT_END handlers are expanded into "when all others" handlers: | |
1760 | ||
1761 | -- exception | |
1762 | -- when all others => | |
1763 | -- _finalizer; -- appears to require elab checks | |
1764 | -- at end | |
1765 | -- _finalizer; | |
1766 | -- end; | |
1767 | ||
1768 | -- Since the compiler guarantees that the body of a _finalizer is | |
1769 | -- always inserted in the same construct where the AT_END handler | |
1770 | -- resides, there is no need for elaboration checks. | |
1771 | ||
1772 | Set_Kill_Elaboration_Checks (Fin_Id); | |
7d9880c9 AC |
1773 | |
1774 | -- Inlining the finalizer produces a substantial speedup at -O2. | |
1775 | -- It is inlined by default at -O3. Either way, it is called | |
1776 | -- exactly twice (once on the normal path, and once for | |
1777 | -- exceptions/abort), so this won't bloat the code too much. | |
1778 | ||
bbf14e13 AC |
1779 | Set_Is_Inlined (Fin_Id); |
1780 | end if; | |
1781 | ||
1782 | if Debug_Generated_Code then | |
1783 | Set_Debug_Info_Needed (Fin_Id); | |
df3e68b1 | 1784 | end if; |
70482933 | 1785 | |
cfae2bed | 1786 | -- Step 2: Creation of the finalizer specification |
df3e68b1 HK |
1787 | |
1788 | -- Generate: | |
1789 | -- procedure Fin_Id; | |
1790 | ||
cfae2bed AC |
1791 | Fin_Spec := |
1792 | Make_Subprogram_Declaration (Loc, | |
1793 | Specification => | |
1794 | Make_Procedure_Specification (Loc, | |
1795 | Defining_Unit_Name => Fin_Id)); | |
70482933 | 1796 | |
213c9dc7 AC |
1797 | if For_Package then |
1798 | Set_Is_Exported (Fin_Id); | |
1799 | Set_Interface_Name (Fin_Id, | |
1800 | Make_String_Literal (Loc, | |
1801 | Strval => Get_Name_String (Chars (Fin_Id)))); | |
1802 | end if; | |
1803 | ||
df3e68b1 | 1804 | -- Step 3: Creation of the finalizer body |
70482933 | 1805 | |
213c9dc7 AC |
1806 | -- Has_Ctrl_Objs might be set because of a generic package body having |
1807 | -- controlled objects. In this case, Jump_Alts may be empty and no | |
1808 | -- case nor goto statements are needed. | |
70482933 | 1809 | |
213c9dc7 AC |
1810 | if Has_Ctrl_Objs |
1811 | and then not Is_Empty_List (Jump_Alts) | |
1812 | then | |
df3e68b1 | 1813 | -- Add L0, the default destination to the jump block |
70482933 | 1814 | |
cfae2bed | 1815 | Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); |
df3e68b1 HK |
1816 | Set_Entity (Label_Id, |
1817 | Make_Defining_Identifier (Loc, Chars (Label_Id))); | |
1818 | Label := Make_Label (Loc, Label_Id); | |
a9f4e3d2 | 1819 | |
df3e68b1 HK |
1820 | -- Generate: |
1821 | -- L0 : label; | |
70482933 | 1822 | |
df3e68b1 HK |
1823 | Prepend_To (Finalizer_Decls, |
1824 | Make_Implicit_Label_Declaration (Loc, | |
1825 | Defining_Identifier => Entity (Label_Id), | |
cfae2bed | 1826 | Label_Construct => Label)); |
70482933 | 1827 | |
df3e68b1 HK |
1828 | -- Generate: |
1829 | -- when others => | |
1830 | -- goto L0; | |
1831 | ||
1832 | Append_To (Jump_Alts, | |
1833 | Make_Case_Statement_Alternative (Loc, | |
cfae2bed AC |
1834 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), |
1835 | Statements => New_List ( | |
df3e68b1 | 1836 | Make_Goto_Statement (Loc, |
e4494292 | 1837 | Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); |
df3e68b1 HK |
1838 | |
1839 | -- Generate: | |
1840 | -- <<L0>> | |
1841 | ||
1842 | Append_To (Finalizer_Stmts, Label); | |
1843 | ||
df3e68b1 HK |
1844 | -- Create the jump block which controls the finalization flow |
1845 | -- depending on the value of the state counter. | |
1846 | ||
1847 | Jump_Block := | |
1848 | Make_Case_Statement (Loc, | |
cfae2bed | 1849 | Expression => Make_Identifier (Loc, Chars (Counter_Id)), |
df3e68b1 HK |
1850 | Alternatives => Jump_Alts); |
1851 | ||
36295779 | 1852 | if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then |
df3e68b1 HK |
1853 | Insert_After (Jump_Block_Insert_Nod, Jump_Block); |
1854 | else | |
1855 | Prepend_To (Finalizer_Stmts, Jump_Block); | |
1856 | end if; | |
70482933 RK |
1857 | end if; |
1858 | ||
26e7e1a0 AC |
1859 | -- Add the library-level tagged type unregistration machinery before |
1860 | -- the jump block circuitry. This ensures that external tags will be | |
1861 | -- removed even if a finalization exception occurs at some point. | |
1862 | ||
1863 | if Has_Tagged_Types then | |
1864 | Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts); | |
1865 | end if; | |
1866 | ||
df3e68b1 HK |
1867 | -- Add a call to the previous At_End handler if it exists. The call |
1868 | -- must always precede the jump block. | |
70482933 | 1869 | |
df3e68b1 HK |
1870 | if Present (Prev_At_End) then |
1871 | Prepend_To (Finalizer_Stmts, | |
1872 | Make_Procedure_Call_Statement (Loc, Prev_At_End)); | |
1873 | ||
1874 | -- Clear the At_End handler since we have already generated the | |
1875 | -- proper replacement call for it. | |
1876 | ||
1877 | Set_At_End_Proc (HSS, Empty); | |
70482933 | 1878 | end if; |
70482933 | 1879 | |
9a975bfc | 1880 | -- Release the secondary stack |
70482933 | 1881 | |
df3e68b1 | 1882 | if Present (Mark_Id) then |
9a975bfc | 1883 | declare |
b6784d90 HK |
1884 | Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id); |
1885 | ||
9a975bfc | 1886 | begin |
b6784d90 HK |
1887 | -- If the context is a build-in-place function, the secondary |
1888 | -- stack must be released, unless the build-in-place function | |
1889 | -- itself is returning on the secondary stack. Generate: | |
1890 | -- | |
1891 | -- if BIP_Alloc_Form /= Secondary_Stack then | |
1892 | -- SS_Release (Mark_Id); | |
1893 | -- end if; | |
1894 | -- | |
1895 | -- Note that if the function returns on the secondary stack, | |
1896 | -- then the responsibility of reclaiming the space is always | |
1897 | -- left to the caller (recursively if needed). | |
9a975bfc BD |
1898 | |
1899 | if Nkind (N) = N_Subprogram_Body then | |
1900 | declare | |
1901 | Spec_Id : constant Entity_Id := | |
1902 | Unique_Defining_Entity (N); | |
1903 | BIP_SS : constant Boolean := | |
1904 | Is_Build_In_Place_Function (Spec_Id) | |
1905 | and then Needs_BIP_Alloc_Form (Spec_Id); | |
1906 | begin | |
1907 | if BIP_SS then | |
1908 | Release := | |
1909 | Make_If_Statement (Loc, | |
b6784d90 | 1910 | Condition => |
9a975bfc BD |
1911 | Make_Op_Ne (Loc, |
1912 | Left_Opnd => | |
1913 | New_Occurrence_Of | |
1914 | (Build_In_Place_Formal | |
1915 | (Spec_Id, BIP_Alloc_Form), Loc), | |
1916 | Right_Opnd => | |
1917 | Make_Integer_Literal (Loc, | |
b6784d90 HK |
1918 | UI_From_Int |
1919 | (BIP_Allocation_Form'Pos | |
1920 | (Secondary_Stack)))), | |
9a975bfc BD |
1921 | |
1922 | Then_Statements => New_List (Release)); | |
1923 | end if; | |
1924 | end; | |
1925 | end if; | |
1926 | ||
1927 | Append_To (Finalizer_Stmts, Release); | |
1928 | end; | |
df3e68b1 | 1929 | end if; |
dbe13a37 | 1930 | |
df3e68b1 | 1931 | -- Protect the statements with abort defer/undefer. This is only when |
40c21e91 | 1932 | -- aborts are allowed and the cleanup statements require deferral or |
7bf911b5 HK |
1933 | -- there are controlled objects to be finalized. Note that the abort |
1934 | -- defer/undefer pair does not require an extra block because each | |
1935 | -- finalization exception is caught in its corresponding finalization | |
1936 | -- block. As a result, the call to Abort_Defer always takes place. | |
70482933 | 1937 | |
36295779 | 1938 | if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then |
df3e68b1 | 1939 | Prepend_To (Finalizer_Stmts, |
7bf911b5 | 1940 | Build_Runtime_Call (Loc, RE_Abort_Defer)); |
dcfa065d | 1941 | |
df3e68b1 | 1942 | Append_To (Finalizer_Stmts, |
7bf911b5 | 1943 | Build_Runtime_Call (Loc, RE_Abort_Undefer)); |
df3e68b1 | 1944 | end if; |
70482933 | 1945 | |
3235dc87 AC |
1946 | -- The local exception does not need to be reraised for library-level |
1947 | -- finalizers. Note that this action must be carried out after object | |
40c21e91 | 1948 | -- cleanup, secondary stack release, and abort undeferral. Generate: |
3235dc87 AC |
1949 | |
1950 | -- if Raised and then not Abort then | |
1951 | -- Raise_From_Controlled_Operation (E); | |
1952 | -- end if; | |
1953 | ||
36295779 | 1954 | if Has_Ctrl_Objs and Exceptions_OK and not For_Package then |
3235dc87 AC |
1955 | Append_To (Finalizer_Stmts, |
1956 | Build_Raise_Statement (Finalizer_Data)); | |
1957 | end if; | |
1958 | ||
df3e68b1 HK |
1959 | -- Generate: |
1960 | -- procedure Fin_Id is | |
14848f57 | 1961 | -- Abort : constant Boolean := Triggered_By_Abort; |
f9ad6b62 AC |
1962 | -- <or> |
1963 | -- Abort : constant Boolean := False; -- no abort | |
1964 | ||
df3e68b1 HK |
1965 | -- E : Exception_Occurrence; -- All added if flag |
1966 | -- Raised : Boolean := False; -- Has_Ctrl_Objs is set | |
1967 | -- L0 : label; | |
1968 | -- ... | |
1969 | -- Lnn : label; | |
f9ad6b62 | 1970 | |
df3e68b1 HK |
1971 | -- begin |
1972 | -- Abort_Defer; -- Added if abort is allowed | |
1973 | -- <call to Prev_At_End> -- Added if exists | |
1974 | -- <cleanup statements> -- Added if Acts_As_Clean | |
1975 | -- <jump block> -- Added if Has_Ctrl_Objs | |
1976 | -- <finalization statements> -- Added if Has_Ctrl_Objs | |
1977 | -- <stack release> -- Added if Mark_Id exists | |
1978 | -- Abort_Undefer; -- Added if abort is allowed | |
3235dc87 | 1979 | -- <exception propagation> -- Added if Has_Ctrl_Objs |
df3e68b1 HK |
1980 | -- end Fin_Id; |
1981 | ||
df3e68b1 | 1982 | -- Create the body of the finalizer |
70482933 | 1983 | |
cfae2bed AC |
1984 | Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); |
1985 | ||
bbf14e13 AC |
1986 | if Debug_Generated_Code then |
1987 | Set_Debug_Info_Needed (Body_Id); | |
1988 | end if; | |
1989 | ||
cfae2bed AC |
1990 | if For_Package then |
1991 | Set_Has_Qualified_Name (Body_Id); | |
1992 | Set_Has_Fully_Qualified_Name (Body_Id); | |
1993 | end if; | |
1994 | ||
df3e68b1 HK |
1995 | Fin_Body := |
1996 | Make_Subprogram_Body (Loc, | |
886b5a18 | 1997 | Specification => |
df3e68b1 | 1998 | Make_Procedure_Specification (Loc, |
cfae2bed | 1999 | Defining_Unit_Name => Body_Id), |
886b5a18 | 2000 | Declarations => Finalizer_Decls, |
df3e68b1 | 2001 | Handled_Statement_Sequence => |
7bf911b5 HK |
2002 | Make_Handled_Sequence_Of_Statements (Loc, |
2003 | Statements => Finalizer_Stmts)); | |
70482933 | 2004 | |
df3e68b1 | 2005 | -- Step 4: Spec and body insertion, analysis |
70482933 | 2006 | |
df3e68b1 | 2007 | if For_Package then |
70482933 | 2008 | |
df3e68b1 HK |
2009 | -- If the package spec has private declarations, the finalizer |
2010 | -- body must be added to the end of the list in order to have | |
b37d5bc6 | 2011 | -- visibility of all private controlled objects. |
70482933 | 2012 | |
df3e68b1 | 2013 | if For_Package_Spec then |
df3e68b1 | 2014 | if Present (Priv_Decls) then |
b37d5bc6 | 2015 | Append_To (Priv_Decls, Fin_Spec); |
df3e68b1 HK |
2016 | Append_To (Priv_Decls, Fin_Body); |
2017 | else | |
b37d5bc6 | 2018 | Append_To (Decls, Fin_Spec); |
df3e68b1 HK |
2019 | Append_To (Decls, Fin_Body); |
2020 | end if; | |
70482933 | 2021 | |
b37d5bc6 AC |
2022 | -- For package bodies, both the finalizer spec and body are |
2023 | -- inserted at the end of the package declarations. | |
70482933 | 2024 | |
df3e68b1 | 2025 | else |
b37d5bc6 AC |
2026 | Append_To (Decls, Fin_Spec); |
2027 | Append_To (Decls, Fin_Body); | |
df3e68b1 | 2028 | end if; |
70482933 | 2029 | |
df3e68b1 | 2030 | -- Push the name of the package |
70482933 | 2031 | |
df3e68b1 | 2032 | Push_Scope (Spec_Id); |
cfae2bed | 2033 | Analyze (Fin_Spec); |
df3e68b1 HK |
2034 | Analyze (Fin_Body); |
2035 | Pop_Scope; | |
70482933 | 2036 | |
df3e68b1 | 2037 | -- Non-package case |
70482933 | 2038 | |
df3e68b1 HK |
2039 | else |
2040 | -- Create the spec for the finalizer. The At_End handler must be | |
2041 | -- able to call the body which resides in a nested structure. | |
2042 | ||
2043 | -- Generate: | |
2044 | -- declare | |
2045 | -- procedure Fin_Id; -- Spec | |
2046 | -- begin | |
2047 | -- <objects and possibly statements> | |
2048 | -- procedure Fin_Id is ... -- Body | |
2049 | -- <statements> | |
2050 | -- at end | |
2051 | -- Fin_Id; -- At_End handler | |
2052 | -- end; | |
2053 | ||
df3e68b1 HK |
2054 | pragma Assert (Present (Spec_Decls)); |
2055 | ||
a1023434 JS |
2056 | -- It maybe possible that we are finalizing 'Old objects which |
2057 | -- exist in the spec declarations. When this is the case the | |
2058 | -- Finalizer_Insert_Node will come before the end of the | |
2059 | -- Spec_Decls. So, to mitigate this, we insert the finalizer spec | |
2060 | -- earlier at the Finalizer_Insert_Nod instead of appending to the | |
2061 | -- end of Spec_Decls to prevent its body appearing before its | |
2062 | -- corresponding spec. | |
2063 | ||
2064 | if Present (Finalizer_Insert_Nod) | |
2065 | and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls | |
2066 | then | |
2067 | Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec); | |
2068 | Finalizer_Insert_Nod := Fin_Spec; | |
2069 | ||
2070 | -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls | |
2071 | ||
2072 | else | |
2073 | Append_To (Spec_Decls, Fin_Spec); | |
2074 | Analyze (Fin_Spec); | |
2075 | end if; | |
df3e68b1 | 2076 | |
40c21e91 | 2077 | -- When the finalizer acts solely as a cleanup routine, the body |
df3e68b1 HK |
2078 | -- is inserted right after the spec. |
2079 | ||
41c79d60 | 2080 | if Acts_As_Clean and not Has_Ctrl_Objs then |
df3e68b1 HK |
2081 | Insert_After (Fin_Spec, Fin_Body); |
2082 | ||
2083 | -- In all other cases the body is inserted after either: | |
2084 | -- | |
2085 | -- 1) The counter update statement of the last controlled object | |
2086 | -- 2) The last top level nested controlled package | |
2087 | -- 3) The last top level controlled instantiation | |
70482933 | 2088 | |
df3e68b1 HK |
2089 | else |
2090 | -- Manually freeze the spec. This is somewhat of a hack because | |
2091 | -- a subprogram is frozen when its body is seen and the freeze | |
2092 | -- node appears right before the body. However, in this case, | |
2093 | -- the spec must be frozen earlier since the At_End handler | |
2094 | -- must be able to call it. | |
2095 | -- | |
2096 | -- declare | |
2097 | -- procedure Fin_Id; -- Spec | |
2098 | -- [Fin_Id] -- Freeze node | |
2099 | -- begin | |
2100 | -- ... | |
2101 | -- at end | |
2102 | -- Fin_Id; -- At_End handler | |
2103 | -- end; | |
2104 | ||
2105 | Ensure_Freeze_Node (Fin_Id); | |
2106 | Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); | |
2107 | Set_Is_Frozen (Fin_Id); | |
2108 | ||
2109 | -- In the case where the last construct to contain a controlled | |
1cdfa9be AC |
2110 | -- object is either a nested package, an instantiation or a |
2111 | -- freeze node, the body must be inserted directly after the | |
2112 | -- construct. | |
df3e68b1 | 2113 | |
4a08c95c AC |
2114 | if Nkind (Last_Top_Level_Ctrl_Construct) in |
2115 | N_Freeze_Entity | N_Package_Declaration | N_Package_Body | |
df3e68b1 HK |
2116 | then |
2117 | Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; | |
2118 | end if; | |
70482933 | 2119 | |
df3e68b1 HK |
2120 | Insert_After (Finalizer_Insert_Nod, Fin_Body); |
2121 | end if; | |
2122 | ||
b3db0949 | 2123 | Analyze (Fin_Body, Suppress => All_Checks); |
df3e68b1 | 2124 | end if; |
39c20502 YM |
2125 | |
2126 | -- Never consider that the finalizer procedure is enabled Ghost, even | |
2127 | -- when the corresponding unit is Ghost, as this would lead to an | |
2128 | -- an external name with a ___ghost_ prefix that the binder cannot | |
2129 | -- generate, as it has no knowledge of the Ghost status of units. | |
2130 | ||
2131 | Set_Is_Checked_Ghost_Entity (Fin_Id, False); | |
df3e68b1 HK |
2132 | end Create_Finalizer; |
2133 | ||
213c9dc7 AC |
2134 | ------------------------ |
2135 | -- New_Finalizer_Name -- | |
2136 | ------------------------ | |
2137 | ||
2138 | function New_Finalizer_Name | |
2139 | (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id | |
2140 | is | |
2141 | procedure New_Finalizer_Name (Id : Entity_Id); | |
2142 | -- Place "__<name-of-Id>" in the name buffer. If the identifier | |
2143 | -- has a non-standard scope, process the scope first. | |
2144 | ||
2145 | ------------------------ | |
2146 | -- New_Finalizer_Name -- | |
2147 | ------------------------ | |
2148 | ||
2149 | procedure New_Finalizer_Name (Id : Entity_Id) is | |
2150 | begin | |
2151 | if Scope (Id) = Standard_Standard then | |
2152 | Get_Name_String (Chars (Id)); | |
2153 | ||
2154 | else | |
2155 | New_Finalizer_Name (Scope (Id)); | |
2156 | Add_Str_To_Name_Buffer ("__"); | |
2157 | Get_Name_String_And_Append (Chars (Id)); | |
2158 | end if; | |
2159 | end New_Finalizer_Name; | |
2160 | ||
2161 | -- Start of processing for New_Finalizer_Name | |
2162 | ||
2163 | begin | |
2164 | -- Create the fully qualified name of the enclosing scope | |
2165 | ||
2166 | New_Finalizer_Name (Spec_Id); | |
2167 | ||
2168 | -- Generate: | |
2169 | -- __finalize_[spec|body] | |
2170 | ||
2171 | Add_Str_To_Name_Buffer ("__finalize_"); | |
2172 | ||
2173 | if For_Spec then | |
2174 | Add_Str_To_Name_Buffer ("spec"); | |
2175 | else | |
2176 | Add_Str_To_Name_Buffer ("body"); | |
2177 | end if; | |
2178 | ||
2179 | return Name_Find; | |
2180 | end New_Finalizer_Name; | |
2181 | ||
df3e68b1 HK |
2182 | -------------------------- |
2183 | -- Process_Declarations -- | |
2184 | -------------------------- | |
2185 | ||
2186 | procedure Process_Declarations | |
2187 | (Decls : List_Id; | |
2188 | Preprocess : Boolean := False; | |
2189 | Top_Level : Boolean := False) | |
2190 | is | |
2191 | Decl : Node_Id; | |
2192 | Expr : Node_Id; | |
2193 | Obj_Id : Entity_Id; | |
2194 | Obj_Typ : Entity_Id; | |
2195 | Pack_Id : Entity_Id; | |
2196 | Spec : Node_Id; | |
2197 | Typ : Entity_Id; | |
2198 | ||
16e764a7 | 2199 | Old_Counter_Val : Nat; |
df3e68b1 HK |
2200 | -- This variable is used to determine whether a nested package or |
2201 | -- instance contains at least one controlled object. | |
2202 | ||
2203 | procedure Processing_Actions | |
2204 | (Has_No_Init : Boolean := False; | |
2205 | Is_Protected : Boolean := False); | |
2206 | -- Depending on the mode of operation of Process_Declarations, either | |
2207 | -- increment the controlled object counter, set the controlled object | |
2208 | -- flag and store the last top level construct or process the current | |
2209 | -- declaration. Flag Has_No_Init is used to propagate scenarios where | |
2210 | -- the current declaration may not have initialization proc(s). Flag | |
2211 | -- Is_Protected should be set when the current declaration denotes a | |
2212 | -- simple protected object. | |
2213 | ||
2214 | ------------------------ | |
2215 | -- Processing_Actions -- | |
2216 | ------------------------ | |
2217 | ||
2218 | procedure Processing_Actions | |
2219 | (Has_No_Init : Boolean := False; | |
2220 | Is_Protected : Boolean := False) | |
2221 | is | |
2222 | begin | |
26e7e1a0 | 2223 | -- Library-level tagged type |
df3e68b1 | 2224 | |
26e7e1a0 AC |
2225 | if Nkind (Decl) = N_Full_Type_Declaration then |
2226 | if Preprocess then | |
2227 | Has_Tagged_Types := True; | |
2228 | ||
36295779 | 2229 | if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then |
26e7e1a0 AC |
2230 | Last_Top_Level_Ctrl_Construct := Decl; |
2231 | end if; | |
0319cacc | 2232 | |
26e7e1a0 AC |
2233 | else |
2234 | Process_Tagged_Type_Declaration (Decl); | |
df3e68b1 | 2235 | end if; |
26e7e1a0 AC |
2236 | |
2237 | -- Controlled object declaration | |
2238 | ||
df3e68b1 | 2239 | else |
26e7e1a0 AC |
2240 | if Preprocess then |
2241 | Counter_Val := Counter_Val + 1; | |
2242 | Has_Ctrl_Objs := True; | |
2243 | ||
36295779 | 2244 | if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then |
26e7e1a0 AC |
2245 | Last_Top_Level_Ctrl_Construct := Decl; |
2246 | end if; | |
0319cacc | 2247 | |
26e7e1a0 AC |
2248 | else |
2249 | Process_Object_Declaration (Decl, Has_No_Init, Is_Protected); | |
2250 | end if; | |
df3e68b1 HK |
2251 | end if; |
2252 | end Processing_Actions; | |
2253 | ||
2254 | -- Start of processing for Process_Declarations | |
2255 | ||
2256 | begin | |
2257 | if No (Decls) or else Is_Empty_List (Decls) then | |
2258 | return; | |
2259 | end if; | |
2260 | ||
2261 | -- Process all declarations in reverse order | |
2262 | ||
2263 | Decl := Last_Non_Pragma (Decls); | |
2264 | while Present (Decl) loop | |
a1023434 JS |
2265 | -- Depending on the value of flag Finalize_Old_Only we determine |
2266 | -- which objects get finalized as part of the current finalizer | |
2267 | -- being built. | |
2268 | ||
2269 | -- When True, only temporaries capturing the value of attribute | |
2270 | -- 'Old are finalized and all other cases are ignored. | |
2271 | ||
2272 | -- When False, temporary objects used to capture the value of 'Old | |
2273 | -- are ignored and all others are considered. | |
2274 | ||
2275 | if Finalize_Old_Only | |
2276 | xor (Nkind (Decl) = N_Object_Declaration | |
2277 | and then Stores_Attribute_Old_Prefix | |
2278 | (Defining_Identifier (Decl))) | |
2279 | then | |
2280 | null; | |
2281 | ||
26e7e1a0 AC |
2282 | -- Library-level tagged types |
2283 | ||
a1023434 | 2284 | elsif Nkind (Decl) = N_Full_Type_Declaration then |
26e7e1a0 AC |
2285 | Typ := Defining_Identifier (Decl); |
2286 | ||
8636f52f HK |
2287 | -- Ignored Ghost types do not need any cleanup actions because |
2288 | -- they will not appear in the final tree. | |
2289 | ||
2290 | if Is_Ignored_Ghost_Entity (Typ) then | |
2291 | null; | |
2292 | ||
2293 | elsif Is_Tagged_Type (Typ) | |
26e7e1a0 AC |
2294 | and then Is_Library_Level_Entity (Typ) |
2295 | and then Convention (Typ) = Convention_Ada | |
2296 | and then Present (Access_Disp_Table (Typ)) | |
2297 | and then RTE_Available (RE_Register_Tag) | |
26e7e1a0 | 2298 | and then not Is_Abstract_Type (Typ) |
8636f52f | 2299 | and then not No_Run_Time_Mode |
26e7e1a0 AC |
2300 | then |
2301 | Processing_Actions; | |
2302 | end if; | |
2303 | ||
df3e68b1 HK |
2304 | -- Regular object declarations |
2305 | ||
26e7e1a0 | 2306 | elsif Nkind (Decl) = N_Object_Declaration then |
df3e68b1 HK |
2307 | Obj_Id := Defining_Identifier (Decl); |
2308 | Obj_Typ := Base_Type (Etype (Obj_Id)); | |
2309 | Expr := Expression (Decl); | |
2310 | ||
2311 | -- Bypass any form of processing for objects which have their | |
2312 | -- finalization disabled. This applies only to objects at the | |
2313 | -- library level. | |
2314 | ||
36295779 | 2315 | if For_Package and then Finalize_Storage_Only (Obj_Typ) then |
df3e68b1 HK |
2316 | null; |
2317 | ||
937e9676 AC |
2318 | -- Finalization of transient objects are treated separately in |
2319 | -- order to handle sensitive cases. These include: | |
df3e68b1 | 2320 | |
937e9676 AC |
2321 | -- * Aggregate expansion |
2322 | -- * If, case, and expression with actions expansion | |
2323 | -- * Transient scopes | |
2324 | ||
2325 | -- If one of those contexts has marked the transient object as | |
2326 | -- ignored, do not generate finalization actions for it. | |
2327 | ||
2328 | elsif Is_Finalized_Transient (Obj_Id) | |
2329 | or else Is_Ignored_Transient (Obj_Id) | |
2330 | then | |
df3e68b1 HK |
2331 | null; |
2332 | ||
8636f52f HK |
2333 | -- Ignored Ghost objects do not need any cleanup actions |
2334 | -- because they will not appear in the final tree. | |
2335 | ||
2336 | elsif Is_Ignored_Ghost_Entity (Obj_Id) then | |
2337 | null; | |
2338 | ||
df3e68b1 | 2339 | -- The object is of the form: |
3386e3ae | 2340 | -- Obj : [constant] Typ [:= Expr]; |
886b5a18 | 2341 | |
3386e3ae AC |
2342 | -- Do not process tag-to-class-wide conversions because they do |
2343 | -- not yield an object. Do not process the incomplete view of a | |
2344 | -- deferred constant. Note that an object initialized by means | |
2345 | -- of a build-in-place function call may appear as a deferred | |
2346 | -- constant after expansion activities. These kinds of objects | |
2347 | -- must be finalized. | |
df3e68b1 HK |
2348 | |
2349 | elsif not Is_Imported (Obj_Id) | |
2350 | and then Needs_Finalization (Obj_Typ) | |
aab08130 | 2351 | and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) |
3386e3ae AC |
2352 | and then not (Ekind (Obj_Id) = E_Constant |
2353 | and then not Has_Completion (Obj_Id) | |
2354 | and then No (BIP_Initialization_Call (Obj_Id))) | |
df3e68b1 HK |
2355 | then |
2356 | Processing_Actions; | |
2357 | ||
2358 | -- The object is of the form: | |
2359 | -- Obj : Access_Typ := Non_BIP_Function_Call'reference; | |
886b5a18 | 2360 | |
df3e68b1 | 2361 | -- Obj : Access_Typ := |
cdc96e3e | 2362 | -- BIP_Function_Call (BIPalloc => 2, ...)'reference; |
df3e68b1 HK |
2363 | |
2364 | elsif Is_Access_Type (Obj_Typ) | |
2365 | and then Needs_Finalization | |
2366 | (Available_View (Designated_Type (Obj_Typ))) | |
2367 | and then Present (Expr) | |
2368 | and then | |
cdc96e3e | 2369 | (Is_Secondary_Stack_BIP_Func_Call (Expr) |
57a3fca9 AC |
2370 | or else |
2371 | (Is_Non_BIP_Func_Call (Expr) | |
2372 | and then not Is_Related_To_Func_Return (Obj_Id))) | |
df3e68b1 HK |
2373 | then |
2374 | Processing_Actions (Has_No_Init => True); | |
2375 | ||
937e9676 AC |
2376 | -- Processing for "hook" objects generated for transient |
2377 | -- objects declared inside an Expression_With_Actions. | |
2d395256 | 2378 | |
35a1c212 | 2379 | elsif Is_Access_Type (Obj_Typ) |
3cebd1c0 AC |
2380 | and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) |
2381 | and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = | |
41c79d60 | 2382 | N_Object_Declaration |
3cebd1c0 AC |
2383 | then |
2384 | Processing_Actions (Has_No_Init => True); | |
2385 | ||
9b16cb57 RD |
2386 | -- Process intermediate results of an if expression with one |
2387 | -- of the alternatives using a controlled function call. | |
3cebd1c0 AC |
2388 | |
2389 | elsif Is_Access_Type (Obj_Typ) | |
2390 | and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) | |
2391 | and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = | |
2a290fec | 2392 | N_Defining_Identifier |
3cebd1c0 AC |
2393 | and then Present (Expr) |
2394 | and then Nkind (Expr) = N_Null | |
35a1c212 AC |
2395 | then |
2396 | Processing_Actions (Has_No_Init => True); | |
2397 | ||
df3e68b1 HK |
2398 | -- Simple protected objects which use type System.Tasking. |
2399 | -- Protected_Objects.Protection to manage their locks should | |
2400 | -- be treated as controlled since they require manual cleanup. | |
2401 | -- The only exception is illustrated in the following example: | |
2402 | ||
2403 | -- package Pkg is | |
2404 | -- type Ctrl is new Controlled ... | |
2405 | -- procedure Finalize (Obj : in out Ctrl); | |
2406 | -- Lib_Obj : Ctrl; | |
2407 | -- end Pkg; | |
2408 | ||
2409 | -- package body Pkg is | |
2410 | -- protected Prot is | |
2411 | -- procedure Do_Something (Obj : in out Ctrl); | |
2412 | -- end Prot; | |
886b5a18 | 2413 | |
df3e68b1 HK |
2414 | -- protected body Prot is |
2415 | -- procedure Do_Something (Obj : in out Ctrl) is ... | |
2416 | -- end Prot; | |
886b5a18 | 2417 | |
df3e68b1 HK |
2418 | -- procedure Finalize (Obj : in out Ctrl) is |
2419 | -- begin | |
2420 | -- Prot.Do_Something (Obj); | |
2421 | -- end Finalize; | |
2422 | -- end Pkg; | |
2423 | ||
2424 | -- Since for the most part entities in package bodies depend on | |
2425 | -- those in package specs, Prot's lock should be cleaned up | |
2426 | -- first. The subsequent cleanup of the spec finalizes Lib_Obj. | |
2427 | -- This act however attempts to invoke Do_Something and fails | |
2428 | -- because the lock has disappeared. | |
2429 | ||
2430 | elsif Ekind (Obj_Id) = E_Variable | |
2431 | and then not In_Library_Level_Package_Body (Obj_Id) | |
41c79d60 AC |
2432 | and then (Is_Simple_Protected_Type (Obj_Typ) |
2433 | or else Has_Simple_Protected_Object (Obj_Typ)) | |
df3e68b1 HK |
2434 | then |
2435 | Processing_Actions (Is_Protected => True); | |
2436 | end if; | |
2437 | ||
2438 | -- Specific cases of object renamings | |
2439 | ||
aab08130 | 2440 | elsif Nkind (Decl) = N_Object_Renaming_Declaration then |
df3e68b1 HK |
2441 | Obj_Id := Defining_Identifier (Decl); |
2442 | Obj_Typ := Base_Type (Etype (Obj_Id)); | |
2443 | ||
2444 | -- Bypass any form of processing for objects which have their | |
2445 | -- finalization disabled. This applies only to objects at the | |
2446 | -- library level. | |
2447 | ||
36295779 | 2448 | if For_Package and then Finalize_Storage_Only (Obj_Typ) then |
df3e68b1 HK |
2449 | null; |
2450 | ||
8636f52f HK |
2451 | -- Ignored Ghost object renamings do not need any cleanup |
2452 | -- actions because they will not appear in the final tree. | |
2453 | ||
2454 | elsif Is_Ignored_Ghost_Entity (Obj_Id) then | |
2455 | null; | |
2456 | ||
df3e68b1 HK |
2457 | -- Return object of a build-in-place function. This case is |
2458 | -- recognized and marked by the expansion of an extended return | |
2459 | -- statement (see Expand_N_Extended_Return_Statement). | |
2460 | ||
2461 | elsif Needs_Finalization (Obj_Typ) | |
2462 | and then Is_Return_Object (Obj_Id) | |
3cebd1c0 | 2463 | and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) |
df3e68b1 HK |
2464 | then |
2465 | Processing_Actions (Has_No_Init => True); | |
aab08130 AC |
2466 | |
2467 | -- Detect a case where a source object has been initialized by | |
a429e6b3 AC |
2468 | -- a controlled function call or another object which was later |
2469 | -- rewritten as a class-wide conversion of Ada.Tags.Displace. | |
aab08130 | 2470 | |
a429e6b3 AC |
2471 | -- Obj1 : CW_Type := Src_Obj; |
2472 | -- Obj2 : CW_Type := Function_Call (...); | |
aab08130 | 2473 | |
a429e6b3 AC |
2474 | -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); |
2475 | -- Tmp : ... := Function_Call (...)'reference; | |
2476 | -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); | |
aab08130 | 2477 | |
a429e6b3 | 2478 | elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then |
aab08130 | 2479 | Processing_Actions (Has_No_Init => True); |
df3e68b1 HK |
2480 | end if; |
2481 | ||
2482 | -- Inspect the freeze node of an access-to-controlled type and | |
d3f70b35 AC |
2483 | -- look for a delayed finalization master. This case arises when |
2484 | -- the freeze actions are inserted at a later time than the | |
df3e68b1 | 2485 | -- expansion of the context. Since Build_Finalizer is never called |
d3f70b35 | 2486 | -- on a single construct twice, the master will be ultimately |
df3e68b1 HK |
2487 | -- left out and never finalized. This is also needed for freeze |
2488 | -- actions of designated types themselves, since in some cases the | |
d3f70b35 | 2489 | -- finalization master is associated with a designated type's |
df3e68b1 | 2490 | -- freeze node rather than that of the access type (see handling |
d3f70b35 | 2491 | -- for freeze actions in Build_Finalization_Master). |
df3e68b1 HK |
2492 | |
2493 | elsif Nkind (Decl) = N_Freeze_Entity | |
2494 | and then Present (Actions (Decl)) | |
2495 | then | |
2496 | Typ := Entity (Decl); | |
2497 | ||
8636f52f HK |
2498 | -- Freeze nodes for ignored Ghost types do not need cleanup |
2499 | -- actions because they will never appear in the final tree. | |
2500 | ||
2501 | if Is_Ignored_Ghost_Entity (Typ) then | |
2502 | null; | |
2503 | ||
5af3a22a | 2504 | elsif (Is_Access_Object_Type (Typ) |
8636f52f HK |
2505 | and then Needs_Finalization |
2506 | (Available_View (Designated_Type (Typ)))) | |
2507 | or else (Is_Type (Typ) and then Needs_Finalization (Typ)) | |
df3e68b1 | 2508 | then |
1cdfa9be AC |
2509 | Old_Counter_Val := Counter_Val; |
2510 | ||
2511 | -- Freeze nodes are considered to be identical to packages | |
2512 | -- and blocks in terms of nesting. The difference is that | |
d3f70b35 AC |
2513 | -- a finalization master created inside the freeze node is |
2514 | -- at the same nesting level as the node itself. | |
1cdfa9be | 2515 | |
df3e68b1 | 2516 | Process_Declarations (Actions (Decl), Preprocess); |
1cdfa9be | 2517 | |
d3f70b35 | 2518 | -- The freeze node contains a finalization master |
1cdfa9be AC |
2519 | |
2520 | if Preprocess | |
2521 | and then Top_Level | |
2522 | and then No (Last_Top_Level_Ctrl_Construct) | |
2523 | and then Counter_Val > Old_Counter_Val | |
2524 | then | |
2525 | Last_Top_Level_Ctrl_Construct := Decl; | |
2526 | end if; | |
df3e68b1 HK |
2527 | end if; |
2528 | ||
2529 | -- Nested package declarations, avoid generics | |
2530 | ||
2531 | elsif Nkind (Decl) = N_Package_Declaration then | |
8636f52f HK |
2532 | Pack_Id := Defining_Entity (Decl); |
2533 | Spec := Specification (Decl); | |
df3e68b1 | 2534 | |
8636f52f HK |
2535 | -- Do not inspect an ignored Ghost package because all code |
2536 | -- found within will not appear in the final tree. | |
2537 | ||
2538 | if Is_Ignored_Ghost_Entity (Pack_Id) then | |
2539 | null; | |
df3e68b1 | 2540 | |
8636f52f | 2541 | elsif Ekind (Pack_Id) /= E_Generic_Package then |
df3e68b1 HK |
2542 | Old_Counter_Val := Counter_Val; |
2543 | Process_Declarations | |
2544 | (Private_Declarations (Spec), Preprocess); | |
2545 | Process_Declarations | |
2546 | (Visible_Declarations (Spec), Preprocess); | |
2547 | ||
2548 | -- Either the visible or the private declarations contain a | |
2549 | -- controlled object. The nested package declaration is the | |
2550 | -- last such construct. | |
2551 | ||
2552 | if Preprocess | |
2553 | and then Top_Level | |
2554 | and then No (Last_Top_Level_Ctrl_Construct) | |
2555 | and then Counter_Val > Old_Counter_Val | |
2556 | then | |
2557 | Last_Top_Level_Ctrl_Construct := Decl; | |
2558 | end if; | |
2559 | end if; | |
2560 | ||
213c9dc7 AC |
2561 | -- Call the xxx__finalize_body procedure of a library level |
2562 | -- package instantiation if the body contains finalization | |
2563 | -- statements. | |
2564 | ||
2565 | if Present (Generic_Parent (Spec)) | |
2566 | and then Is_Library_Level_Entity (Pack_Id) | |
2567 | and then Present (Body_Entity (Generic_Parent (Spec))) | |
2568 | then | |
2569 | if Preprocess then | |
2570 | declare | |
2571 | P : Node_Id; | |
2572 | begin | |
2573 | P := Parent (Body_Entity (Generic_Parent (Spec))); | |
2574 | while Present (P) | |
2575 | and then Nkind (P) /= N_Package_Body | |
2576 | loop | |
2577 | P := Parent (P); | |
2578 | end loop; | |
2579 | ||
2580 | if Present (P) then | |
2581 | Old_Counter_Val := Counter_Val; | |
2582 | Process_Declarations (Declarations (P), Preprocess); | |
2583 | ||
2584 | -- Note that we are processing the generic body | |
2585 | -- template and not the actually instantiation | |
2586 | -- (which is generated too late for us to process | |
2587 | -- it), so there is no need to update in particular | |
2588 | -- to update Last_Top_Level_Ctrl_Construct here. | |
2589 | ||
2590 | if Counter_Val > Old_Counter_Val then | |
2591 | Counter_Val := Old_Counter_Val; | |
2592 | Set_Has_Controlled_Component (Pack_Id); | |
2593 | end if; | |
2594 | end if; | |
2595 | end; | |
2596 | ||
2597 | elsif Has_Controlled_Component (Pack_Id) then | |
2598 | ||
2599 | -- We import the xxx__finalize_body routine since the | |
2600 | -- generic body will be instantiated later. | |
2601 | ||
2602 | declare | |
2603 | Id : constant Node_Id := | |
2604 | Make_Defining_Identifier (Loc, | |
2605 | New_Finalizer_Name (Defining_Unit_Name (Spec), | |
2606 | For_Spec => False)); | |
2607 | ||
2608 | begin | |
2609 | Set_Has_Qualified_Name (Id); | |
2610 | Set_Has_Fully_Qualified_Name (Id); | |
2611 | Set_Is_Imported (Id); | |
2612 | Set_Has_Completion (Id); | |
2613 | Set_Interface_Name (Id, | |
2614 | Make_String_Literal (Loc, | |
2615 | Strval => Get_Name_String (Chars (Id)))); | |
2616 | ||
2617 | Append_New_To (Finalizer_Stmts, | |
2618 | Make_Subprogram_Declaration (Loc, | |
2619 | Make_Procedure_Specification (Loc, | |
2620 | Defining_Unit_Name => Id))); | |
2621 | Append_To (Finalizer_Stmts, | |
2622 | Make_Procedure_Call_Statement (Loc, | |
2623 | Name => New_Occurrence_Of (Id, Loc))); | |
2624 | end; | |
2625 | end if; | |
2626 | end if; | |
2627 | ||
df3e68b1 HK |
2628 | -- Nested package bodies, avoid generics |
2629 | ||
2630 | elsif Nkind (Decl) = N_Package_Body then | |
df3e68b1 | 2631 | |
8636f52f HK |
2632 | -- Do not inspect an ignored Ghost package body because all |
2633 | -- code found within will not appear in the final tree. | |
2634 | ||
2635 | if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then | |
2636 | null; | |
2637 | ||
213c9dc7 | 2638 | elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package |
8636f52f | 2639 | then |
df3e68b1 HK |
2640 | Old_Counter_Val := Counter_Val; |
2641 | Process_Declarations (Declarations (Decl), Preprocess); | |
2642 | ||
2643 | -- The nested package body is the last construct to contain | |
2644 | -- a controlled object. | |
2645 | ||
2646 | if Preprocess | |
2647 | and then Top_Level | |
2648 | and then No (Last_Top_Level_Ctrl_Construct) | |
2649 | and then Counter_Val > Old_Counter_Val | |
2650 | then | |
2651 | Last_Top_Level_Ctrl_Construct := Decl; | |
2652 | end if; | |
2653 | end if; | |
2654 | ||
937e9676 | 2655 | -- Handle a rare case caused by a controlled transient object |
df3e68b1 HK |
2656 | -- created as part of a record init proc. The variable is wrapped |
2657 | -- in a block, but the block is not associated with a transient | |
2658 | -- scope. | |
2659 | ||
2660 | elsif Nkind (Decl) = N_Block_Statement | |
2661 | and then Inside_Init_Proc | |
2662 | then | |
2663 | Old_Counter_Val := Counter_Val; | |
2664 | ||
2665 | if Present (Handled_Statement_Sequence (Decl)) then | |
2666 | Process_Declarations | |
2667 | (Statements (Handled_Statement_Sequence (Decl)), | |
2668 | Preprocess); | |
2669 | end if; | |
2670 | ||
2671 | Process_Declarations (Declarations (Decl), Preprocess); | |
2672 | ||
2673 | -- Either the declaration or statement list of the block has a | |
2674 | -- controlled object. | |
2675 | ||
2676 | if Preprocess | |
2677 | and then Top_Level | |
2678 | and then No (Last_Top_Level_Ctrl_Construct) | |
2679 | and then Counter_Val > Old_Counter_Val | |
2680 | then | |
2681 | Last_Top_Level_Ctrl_Construct := Decl; | |
2682 | end if; | |
e98668b1 AC |
2683 | |
2684 | -- Handle the case where the original context has been wrapped in | |
2685 | -- a block to avoid interference between exception handlers and | |
2686 | -- At_End handlers. Treat the block as transparent and process its | |
2687 | -- contents. | |
2688 | ||
2689 | elsif Nkind (Decl) = N_Block_Statement | |
2690 | and then Is_Finalization_Wrapper (Decl) | |
2691 | then | |
2692 | if Present (Handled_Statement_Sequence (Decl)) then | |
2693 | Process_Declarations | |
2694 | (Statements (Handled_Statement_Sequence (Decl)), | |
2695 | Preprocess); | |
2696 | end if; | |
2697 | ||
2698 | Process_Declarations (Declarations (Decl), Preprocess); | |
df3e68b1 HK |
2699 | end if; |
2700 | ||
2701 | Prev_Non_Pragma (Decl); | |
2702 | end loop; | |
2703 | end Process_Declarations; | |
2704 | ||
2705 | -------------------------------- | |
2706 | -- Process_Object_Declaration -- | |
2707 | -------------------------------- | |
2708 | ||
2709 | procedure Process_Object_Declaration | |
2710 | (Decl : Node_Id; | |
2711 | Has_No_Init : Boolean := False; | |
2712 | Is_Protected : Boolean := False) | |
2713 | is | |
0382062b AC |
2714 | Loc : constant Source_Ptr := Sloc (Decl); |
2715 | Obj_Id : constant Entity_Id := Defining_Identifier (Decl); | |
df3e68b1 | 2716 | |
0382062b AC |
2717 | Init_Typ : Entity_Id; |
2718 | -- The initialization type of the related object declaration. Note | |
2cc2e964 | 2719 | -- that this is not necessarily the same type as Obj_Typ because of |
0382062b AC |
2720 | -- possible type derivations. |
2721 | ||
2722 | Obj_Typ : Entity_Id; | |
2723 | -- The type of the related object declaration | |
2724 | ||
2725 | function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; | |
2726 | -- Func_Id denotes a build-in-place function. Generate the following | |
2727 | -- cleanup code: | |
df3e68b1 HK |
2728 | -- |
2729 | -- if BIPallocfrom > Secondary_Stack'Pos | |
d3f70b35 | 2730 | -- and then BIPfinalizationmaster /= null |
df3e68b1 HK |
2731 | -- then |
2732 | -- declare | |
2733 | -- type Ptr_Typ is access Obj_Typ; | |
d3f70b35 AC |
2734 | -- for Ptr_Typ'Storage_Pool |
2735 | -- use Base_Pool (BIPfinalizationmaster); | |
df3e68b1 HK |
2736 | -- begin |
2737 | -- Free (Ptr_Typ (Temp)); | |
2738 | -- end; | |
2739 | -- end if; | |
2740 | -- | |
2741 | -- Obj_Typ is the type of the current object, Temp is the original | |
2742 | -- allocation which Obj_Id renames. | |
2743 | ||
2744 | procedure Find_Last_Init | |
0382062b | 2745 | (Last_Init : out Node_Id; |
df3e68b1 | 2746 | Body_Insert : out Node_Id); |
4ac2bbbd AC |
2747 | -- Find the last initialization call related to object declaration |
2748 | -- Decl. Last_Init denotes the last initialization call which follows | |
0382062b AC |
2749 | -- Decl. Body_Insert denotes a node where the finalizer body could be |
2750 | -- potentially inserted after (if blocks are involved). | |
df3e68b1 HK |
2751 | |
2752 | ----------------------------- | |
2753 | -- Build_BIP_Cleanup_Stmts -- | |
2754 | ----------------------------- | |
2755 | ||
2756 | function Build_BIP_Cleanup_Stmts | |
0382062b | 2757 | (Func_Id : Entity_Id) return Node_Id |
df3e68b1 | 2758 | is |
d3f70b35 AC |
2759 | Decls : constant List_Id := New_List; |
2760 | Fin_Mas_Id : constant Entity_Id := | |
2761 | Build_In_Place_Formal | |
2762 | (Func_Id, BIP_Finalization_Master); | |
0382062b | 2763 | Func_Typ : constant Entity_Id := Etype (Func_Id); |
d3f70b35 AC |
2764 | Temp_Id : constant Entity_Id := |
2765 | Entity (Prefix (Name (Parent (Obj_Id)))); | |
df3e68b1 HK |
2766 | |
2767 | Cond : Node_Id; | |
2768 | Free_Blk : Node_Id; | |
2769 | Free_Stmt : Node_Id; | |
2770 | Pool_Id : Entity_Id; | |
2771 | Ptr_Typ : Entity_Id; | |
2772 | ||
2773 | begin | |
2774 | -- Generate: | |
d3f70b35 | 2775 | -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all; |
df3e68b1 HK |
2776 | |
2777 | Pool_Id := Make_Temporary (Loc, 'P'); | |
2778 | ||
2779 | Append_To (Decls, | |
2780 | Make_Object_Renaming_Declaration (Loc, | |
2781 | Defining_Identifier => Pool_Id, | |
cfae2bed | 2782 | Subtype_Mark => |
e4494292 | 2783 | New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc), |
cfae2bed | 2784 | Name => |
df3e68b1 HK |
2785 | Make_Explicit_Dereference (Loc, |
2786 | Prefix => | |
2787 | Make_Function_Call (Loc, | |
cfae2bed | 2788 | Name => |
e4494292 | 2789 | New_Occurrence_Of (RTE (RE_Base_Pool), Loc), |
df3e68b1 HK |
2790 | Parameter_Associations => New_List ( |
2791 | Make_Explicit_Dereference (Loc, | |
e4494292 RD |
2792 | Prefix => |
2793 | New_Occurrence_Of (Fin_Mas_Id, Loc))))))); | |
df3e68b1 HK |
2794 | |
2795 | -- Create an access type which uses the storage pool of the | |
d3f70b35 | 2796 | -- caller's finalization master. |
df3e68b1 HK |
2797 | |
2798 | -- Generate: | |
0382062b | 2799 | -- type Ptr_Typ is access Func_Typ; |
df3e68b1 HK |
2800 | |
2801 | Ptr_Typ := Make_Temporary (Loc, 'P'); | |
2802 | ||
2803 | Append_To (Decls, | |
2804 | Make_Full_Type_Declaration (Loc, | |
2805 | Defining_Identifier => Ptr_Typ, | |
cfae2bed | 2806 | Type_Definition => |
df3e68b1 | 2807 | Make_Access_To_Object_Definition (Loc, |
0382062b | 2808 | Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc)))); |
df3e68b1 | 2809 | |
d3f70b35 | 2810 | -- Perform minor decoration in order to set the master and the |
df3e68b1 HK |
2811 | -- storage pool attributes. |
2812 | ||
2e02ab86 | 2813 | Mutate_Ekind (Ptr_Typ, E_Access_Type); |
d3f70b35 | 2814 | Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); |
df3e68b1 HK |
2815 | Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); |
2816 | ||
bbf14e13 AC |
2817 | if Debug_Generated_Code then |
2818 | Set_Debug_Info_Needed (Pool_Id); | |
2819 | end if; | |
2820 | ||
df3e68b1 HK |
2821 | -- Create an explicit free statement. Note that the free uses the |
2822 | -- caller's pool expressed as a renaming. | |
2823 | ||
2824 | Free_Stmt := | |
2825 | Make_Free_Statement (Loc, | |
2826 | Expression => | |
2827 | Unchecked_Convert_To (Ptr_Typ, | |
e4494292 | 2828 | New_Occurrence_Of (Temp_Id, Loc))); |
df3e68b1 HK |
2829 | |
2830 | Set_Storage_Pool (Free_Stmt, Pool_Id); | |
2831 | ||
2832 | -- Create a block to house the dummy type and the instantiation as | |
2833 | -- well as to perform the cleanup the temporary. | |
2834 | ||
2835 | -- Generate: | |
2836 | -- declare | |
2837 | -- <Decls> | |
2838 | -- begin | |
2839 | -- Free (Ptr_Typ (Temp_Id)); | |
2840 | -- end; | |
2841 | ||
2842 | Free_Blk := | |
2843 | Make_Block_Statement (Loc, | |
cfae2bed | 2844 | Declarations => Decls, |
df3e68b1 HK |
2845 | Handled_Statement_Sequence => |
2846 | Make_Handled_Sequence_Of_Statements (Loc, | |
2847 | Statements => New_List (Free_Stmt))); | |
2848 | ||
2849 | -- Generate: | |
d3f70b35 | 2850 | -- if BIPfinalizationmaster /= null then |
df3e68b1 HK |
2851 | |
2852 | Cond := | |
2853 | Make_Op_Ne (Loc, | |
e4494292 | 2854 | Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc), |
cfae2bed | 2855 | Right_Opnd => Make_Null (Loc)); |
df3e68b1 HK |
2856 | |
2857 | -- For constrained or tagged results escalate the condition to | |
2858 | -- include the allocation format. Generate: | |
41c79d60 | 2859 | |
df3e68b1 | 2860 | -- if BIPallocform > Secondary_Stack'Pos |
d3f70b35 | 2861 | -- and then BIPfinalizationmaster /= null |
df3e68b1 HK |
2862 | -- then |
2863 | ||
0382062b AC |
2864 | if not Is_Constrained (Func_Typ) |
2865 | or else Is_Tagged_Type (Func_Typ) | |
df3e68b1 HK |
2866 | then |
2867 | declare | |
2868 | Alloc : constant Entity_Id := | |
2869 | Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); | |
2870 | begin | |
2871 | Cond := | |
2872 | Make_And_Then (Loc, | |
cfae2bed | 2873 | Left_Opnd => |
df3e68b1 | 2874 | Make_Op_Gt (Loc, |
e4494292 | 2875 | Left_Opnd => New_Occurrence_Of (Alloc, Loc), |
df3e68b1 HK |
2876 | Right_Opnd => |
2877 | Make_Integer_Literal (Loc, | |
2878 | UI_From_Int | |
2879 | (BIP_Allocation_Form'Pos (Secondary_Stack)))), | |
2880 | ||
2881 | Right_Opnd => Cond); | |
2882 | end; | |
2883 | end if; | |
2884 | ||
2885 | -- Generate: | |
2886 | -- if <Cond> then | |
2887 | -- <Free_Blk> | |
2888 | -- end if; | |
2889 | ||
2890 | return | |
2891 | Make_If_Statement (Loc, | |
cfae2bed | 2892 | Condition => Cond, |
df3e68b1 HK |
2893 | Then_Statements => New_List (Free_Blk)); |
2894 | end Build_BIP_Cleanup_Stmts; | |
2895 | ||
2896 | -------------------- | |
2897 | -- Find_Last_Init -- | |
2898 | -------------------- | |
2899 | ||
2900 | procedure Find_Last_Init | |
0382062b | 2901 | (Last_Init : out Node_Id; |
df3e68b1 HK |
2902 | Body_Insert : out Node_Id) |
2903 | is | |
0382062b | 2904 | function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id; |
4ac2bbbd | 2905 | -- Find the last initialization call within the statements of |
0382062b | 2906 | -- block Blk. |
4ac2bbbd | 2907 | |
0382062b | 2908 | function Is_Init_Call (N : Node_Id) return Boolean; |
4ac2bbbd | 2909 | -- Determine whether node N denotes one of the initialization |
0382062b | 2910 | -- procedures of types Init_Typ or Obj_Typ. |
df3e68b1 | 2911 | |
97ed5872 | 2912 | function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; |
90e491a7 PMR |
2913 | -- Obtain the next statement which follows list member Stmt while |
2914 | -- ignoring artifacts related to access-before-elaboration checks. | |
4ac2bbbd AC |
2915 | |
2916 | ----------------------------- | |
2917 | -- Find_Last_Init_In_Block -- | |
2918 | ----------------------------- | |
2919 | ||
0382062b | 2920 | function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is |
4ac2bbbd AC |
2921 | HSS : constant Node_Id := Handled_Statement_Sequence (Blk); |
2922 | Stmt : Node_Id; | |
2923 | ||
2924 | begin | |
2925 | -- Examine the individual statements of the block in reverse to | |
2926 | -- locate the last initialization call. | |
2927 | ||
2928 | if Present (HSS) and then Present (Statements (HSS)) then | |
2929 | Stmt := Last (Statements (HSS)); | |
2930 | while Present (Stmt) loop | |
2931 | ||
2932 | -- Peek inside nested blocks in case aborts are allowed | |
2933 | ||
2934 | if Nkind (Stmt) = N_Block_Statement then | |
0382062b | 2935 | return Find_Last_Init_In_Block (Stmt); |
4ac2bbbd | 2936 | |
0382062b | 2937 | elsif Is_Init_Call (Stmt) then |
4ac2bbbd AC |
2938 | return Stmt; |
2939 | end if; | |
2940 | ||
2941 | Prev (Stmt); | |
2942 | end loop; | |
2943 | end if; | |
2944 | ||
2945 | return Empty; | |
2946 | end Find_Last_Init_In_Block; | |
97ed5872 | 2947 | |
df3e68b1 HK |
2948 | ------------------ |
2949 | -- Is_Init_Call -- | |
2950 | ------------------ | |
2951 | ||
0382062b AC |
2952 | function Is_Init_Call (N : Node_Id) return Boolean is |
2953 | function Is_Init_Proc_Of | |
2954 | (Subp_Id : Entity_Id; | |
2955 | Typ : Entity_Id) return Boolean; | |
2956 | -- Determine whether subprogram Subp_Id is a valid init proc of | |
2957 | -- type Typ. | |
2958 | ||
2959 | --------------------- | |
2960 | -- Is_Init_Proc_Of -- | |
2961 | --------------------- | |
2962 | ||
2963 | function Is_Init_Proc_Of | |
2964 | (Subp_Id : Entity_Id; | |
2965 | Typ : Entity_Id) return Boolean | |
2966 | is | |
2967 | Deep_Init : Entity_Id := Empty; | |
2968 | Prim_Init : Entity_Id := Empty; | |
2969 | Type_Init : Entity_Id := Empty; | |
df3e68b1 | 2970 | |
0382062b AC |
2971 | begin |
2972 | -- Obtain all possible initialization routines of the | |
2973 | -- related type and try to match the subprogram entity | |
2974 | -- against one of them. | |
4ac2bbbd AC |
2975 | |
2976 | -- Deep_Initialize | |
2977 | ||
0382062b | 2978 | Deep_Init := TSS (Typ, TSS_Deep_Initialize); |
4ac2bbbd AC |
2979 | |
2980 | -- Primitive Initialize | |
df3e68b1 | 2981 | |
0382062b | 2982 | if Is_Controlled (Typ) then |
ca811241 | 2983 | Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize); |
ca5af305 | 2984 | |
4ac2bbbd AC |
2985 | if Present (Prim_Init) then |
2986 | Prim_Init := Ultimate_Alias (Prim_Init); | |
df3e68b1 | 2987 | end if; |
4ac2bbbd | 2988 | end if; |
df3e68b1 | 2989 | |
4ac2bbbd AC |
2990 | -- Type initialization routine |
2991 | ||
0382062b AC |
2992 | if Has_Non_Null_Base_Init_Proc (Typ) then |
2993 | Type_Init := Base_Init_Proc (Typ); | |
4ac2bbbd AC |
2994 | end if; |
2995 | ||
2996 | return | |
0382062b | 2997 | (Present (Deep_Init) and then Subp_Id = Deep_Init) |
4ac2bbbd | 2998 | or else |
0382062b AC |
2999 | (Present (Prim_Init) and then Subp_Id = Prim_Init) |
3000 | or else | |
3001 | (Present (Type_Init) and then Subp_Id = Type_Init); | |
3002 | end Is_Init_Proc_Of; | |
3003 | ||
3004 | -- Local variables | |
3005 | ||
3006 | Call_Id : Entity_Id; | |
3007 | ||
3008 | -- Start of processing for Is_Init_Call | |
3009 | ||
3010 | begin | |
3011 | if Nkind (N) = N_Procedure_Call_Statement | |
3012 | and then Nkind (Name (N)) = N_Identifier | |
3013 | then | |
3014 | Call_Id := Entity (Name (N)); | |
3015 | ||
3016 | -- Consider both the type of the object declaration and its | |
3017 | -- related initialization type. | |
3018 | ||
3019 | return | |
3020 | Is_Init_Proc_Of (Call_Id, Init_Typ) | |
4ac2bbbd | 3021 | or else |
0382062b | 3022 | Is_Init_Proc_Of (Call_Id, Obj_Typ); |
df3e68b1 HK |
3023 | end if; |
3024 | ||
3025 | return False; | |
3026 | end Is_Init_Call; | |
3027 | ||
97ed5872 AC |
3028 | ----------------------------- |
3029 | -- Next_Suitable_Statement -- | |
3030 | ----------------------------- | |
3031 | ||
3032 | function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is | |
90e491a7 | 3033 | Result : Node_Id; |
97ed5872 AC |
3034 | |
3035 | begin | |
90e491a7 PMR |
3036 | -- Skip call markers and Program_Error raises installed by the |
3037 | -- ABE mechanism. | |
3038 | ||
3039 | Result := Next (Stmt); | |
3040 | while Present (Result) loop | |
4a08c95c AC |
3041 | exit when Nkind (Result) not in |
3042 | N_Call_Marker | N_Raise_Program_Error; | |
97ed5872 | 3043 | |
cbbe41d1 | 3044 | Next (Result); |
90e491a7 | 3045 | end loop; |
97ed5872 AC |
3046 | |
3047 | return Result; | |
3048 | end Next_Suitable_Statement; | |
3049 | ||
7b966a95 AC |
3050 | -- Local variables |
3051 | ||
0382062b AC |
3052 | Call : Node_Id; |
3053 | Stmt : Node_Id; | |
3054 | Stmt_2 : Node_Id; | |
7b966a95 | 3055 | |
b8b2d982 AC |
3056 | Deep_Init_Found : Boolean := False; |
3057 | -- A flag set when a call to [Deep_]Initialize has been found | |
3058 | ||
df3e68b1 HK |
3059 | -- Start of processing for Find_Last_Init |
3060 | ||
3061 | begin | |
3062 | Last_Init := Decl; | |
3063 | Body_Insert := Empty; | |
3064 | ||
3065 | -- Object renamings and objects associated with controlled | |
4ac2bbbd | 3066 | -- function results do not require initialization. |
df3e68b1 HK |
3067 | |
3068 | if Has_No_Init then | |
3069 | return; | |
3070 | end if; | |
3071 | ||
4ac2bbbd AC |
3072 | Stmt := Next_Suitable_Statement (Decl); |
3073 | ||
0691ed6b AC |
3074 | -- For an object with suppressed initialization, we check whether |
3075 | -- there is in fact no initialization expression. If there is not, | |
3076 | -- then this is an object declaration that has been turned into a | |
3077 | -- different object declaration that calls the build-in-place | |
3078 | -- function in a 'Reference attribute, as in "F(...)'Reference". | |
3079 | -- We search for that later object declaration, so that the | |
3080 | -- Inc_Decl will be inserted after the call. Otherwise, if the | |
3081 | -- call raises an exception, we will finalize the (uninitialized) | |
3082 | -- object, which is wrong. | |
7b966a95 | 3083 | |
3386e3ae | 3084 | if No_Initialization (Decl) then |
0691ed6b AC |
3085 | if No (Expression (Last_Init)) then |
3086 | loop | |
cbbe41d1 | 3087 | Next (Last_Init); |
0691ed6b AC |
3088 | exit when No (Last_Init); |
3089 | exit when Nkind (Last_Init) = N_Object_Declaration | |
3090 | and then Nkind (Expression (Last_Init)) = N_Reference | |
3091 | and then Nkind (Prefix (Expression (Last_Init))) = | |
3092 | N_Function_Call | |
3093 | and then Is_Expanded_Build_In_Place_Call | |
3094 | (Prefix (Expression (Last_Init))); | |
3095 | end loop; | |
3096 | end if; | |
3097 | ||
24de083f AC |
3098 | return; |
3099 | ||
4ac2bbbd AC |
3100 | -- In all other cases the initialization calls follow the related |
3101 | -- object. The general structure of object initialization built by | |
3102 | -- routine Default_Initialize_Object is as follows: | |
3103 | ||
3104 | -- [begin -- aborts allowed | |
3105 | -- Abort_Defer;] | |
3106 | -- Type_Init_Proc (Obj); | |
3107 | -- [begin] -- exceptions allowed | |
3108 | -- Deep_Initialize (Obj); | |
3109 | -- [exception -- exceptions allowed | |
3110 | -- when others => | |
3111 | -- Deep_Finalize (Obj, Self => False); | |
3112 | -- raise; | |
3113 | -- end;] | |
3114 | -- [at end -- aborts allowed | |
3115 | -- Abort_Undefer; | |
3116 | -- end;] | |
3117 | ||
3118 | -- When aborts are allowed, the initialization calls are housed | |
3119 | -- within a block. | |
3120 | ||
3121 | elsif Nkind (Stmt) = N_Block_Statement then | |
0382062b | 3122 | Last_Init := Find_Last_Init_In_Block (Stmt); |
4ac2bbbd AC |
3123 | Body_Insert := Stmt; |
3124 | ||
3125 | -- Otherwise the initialization calls follow the related object | |
df3e68b1 | 3126 | |
7b966a95 | 3127 | else |
213c9dc7 AC |
3128 | pragma Assert (Present (Stmt)); |
3129 | ||
4ac2bbbd | 3130 | Stmt_2 := Next_Suitable_Statement (Stmt); |
df3e68b1 | 3131 | |
4ac2bbbd AC |
3132 | -- Check for an optional call to Deep_Initialize which may |
3133 | -- appear within a block depending on whether the object has | |
3134 | -- controlled components. | |
df3e68b1 | 3135 | |
4ac2bbbd AC |
3136 | if Present (Stmt_2) then |
3137 | if Nkind (Stmt_2) = N_Block_Statement then | |
0382062b | 3138 | Call := Find_Last_Init_In_Block (Stmt_2); |
df3e68b1 | 3139 | |
4ac2bbbd | 3140 | if Present (Call) then |
b8b2d982 AC |
3141 | Deep_Init_Found := True; |
3142 | Last_Init := Call; | |
3143 | Body_Insert := Stmt_2; | |
4ac2bbbd | 3144 | end if; |
df3e68b1 | 3145 | |
0382062b | 3146 | elsif Is_Init_Call (Stmt_2) then |
b8b2d982 AC |
3147 | Deep_Init_Found := True; |
3148 | Last_Init := Stmt_2; | |
3149 | Body_Insert := Last_Init; | |
4ac2bbbd | 3150 | end if; |
b8b2d982 | 3151 | end if; |
df3e68b1 | 3152 | |
4ac2bbbd AC |
3153 | -- If the object lacks a call to Deep_Initialize, then it must |
3154 | -- have a call to its related type init proc. | |
df3e68b1 | 3155 | |
b8b2d982 | 3156 | if not Deep_Init_Found and then Is_Init_Call (Stmt) then |
4ac2bbbd AC |
3157 | Last_Init := Stmt; |
3158 | Body_Insert := Last_Init; | |
df3e68b1 HK |
3159 | end if; |
3160 | end if; | |
3161 | end Find_Last_Init; | |
3162 | ||
4ac2bbbd AC |
3163 | -- Local variables |
3164 | ||
4ac2bbbd AC |
3165 | Body_Ins : Node_Id; |
3166 | Count_Ins : Node_Id; | |
3167 | Fin_Call : Node_Id; | |
321c24f7 | 3168 | Fin_Stmts : List_Id := No_List; |
4ac2bbbd AC |
3169 | Inc_Decl : Node_Id; |
3170 | Label : Node_Id; | |
3171 | Label_Id : Entity_Id; | |
3172 | Obj_Ref : Node_Id; | |
4ac2bbbd | 3173 | |
df3e68b1 HK |
3174 | -- Start of processing for Process_Object_Declaration |
3175 | ||
3176 | begin | |
0382062b AC |
3177 | -- Handle the object type and the reference to the object |
3178 | ||
e4494292 | 3179 | Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); |
df3e68b1 HK |
3180 | Obj_Typ := Base_Type (Etype (Obj_Id)); |
3181 | ||
0382062b AC |
3182 | loop |
3183 | if Is_Access_Type (Obj_Typ) then | |
3184 | Obj_Typ := Directly_Designated_Type (Obj_Typ); | |
3185 | Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); | |
df3e68b1 | 3186 | |
0382062b AC |
3187 | elsif Is_Concurrent_Type (Obj_Typ) |
3188 | and then Present (Corresponding_Record_Type (Obj_Typ)) | |
3189 | then | |
3190 | Obj_Typ := Corresponding_Record_Type (Obj_Typ); | |
3191 | Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); | |
3192 | ||
3193 | elsif Is_Private_Type (Obj_Typ) | |
3194 | and then Present (Full_View (Obj_Typ)) | |
3195 | then | |
3196 | Obj_Typ := Full_View (Obj_Typ); | |
3197 | Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); | |
3198 | ||
3199 | elsif Obj_Typ /= Base_Type (Obj_Typ) then | |
3200 | Obj_Typ := Base_Type (Obj_Typ); | |
3201 | Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); | |
3202 | ||
3203 | else | |
3204 | exit; | |
3205 | end if; | |
3206 | end loop; | |
df3e68b1 HK |
3207 | |
3208 | Set_Etype (Obj_Ref, Obj_Typ); | |
3209 | ||
0382062b AC |
3210 | -- Handle the initialization type of the object declaration |
3211 | ||
3212 | Init_Typ := Obj_Typ; | |
3213 | loop | |
3214 | if Is_Private_Type (Init_Typ) | |
3215 | and then Present (Full_View (Init_Typ)) | |
3216 | then | |
3217 | Init_Typ := Full_View (Init_Typ); | |
3218 | ||
3219 | elsif Is_Untagged_Derivation (Init_Typ) then | |
3220 | Init_Typ := Root_Type (Init_Typ); | |
3221 | ||
3222 | else | |
3223 | exit; | |
3224 | end if; | |
3225 | end loop; | |
3226 | ||
df3e68b1 HK |
3227 | -- Set a new value for the state counter and insert the statement |
3228 | -- after the object declaration. Generate: | |
7b966a95 | 3229 | |
df3e68b1 HK |
3230 | -- Counter := <value>; |
3231 | ||
3232 | Inc_Decl := | |
3233 | Make_Assignment_Statement (Loc, | |
e4494292 | 3234 | Name => New_Occurrence_Of (Counter_Id, Loc), |
cfae2bed | 3235 | Expression => Make_Integer_Literal (Loc, Counter_Val)); |
df3e68b1 HK |
3236 | |
3237 | -- Insert the counter after all initialization has been done. The | |
3386e3ae | 3238 | -- place of insertion depends on the context. |
df3e68b1 | 3239 | |
4a08c95c | 3240 | if Ekind (Obj_Id) in E_Constant | E_Variable then |
3386e3ae AC |
3241 | |
3242 | -- The object is initialized by a build-in-place function call. | |
3243 | -- The counter insertion point is after the function call. | |
3244 | ||
3245 | if Present (BIP_Initialization_Call (Obj_Id)) then | |
3246 | Count_Ins := BIP_Initialization_Call (Obj_Id); | |
3247 | Body_Ins := Empty; | |
3248 | ||
3249 | -- The object is initialized by an aggregate. Insert the counter | |
3250 | -- after the last aggregate assignment. | |
3251 | ||
3252 | elsif Present (Last_Aggregate_Assignment (Obj_Id)) then | |
3253 | Count_Ins := Last_Aggregate_Assignment (Obj_Id); | |
3254 | Body_Ins := Empty; | |
3255 | ||
3256 | -- In all other cases the counter is inserted after the last call | |
3257 | -- to either [Deep_]Initialize or the type-specific init proc. | |
3258 | ||
3259 | else | |
3260 | Find_Last_Init (Count_Ins, Body_Ins); | |
3261 | end if; | |
97779c34 AC |
3262 | |
3263 | -- In all other cases the counter is inserted after the last call to | |
3386e3ae | 3264 | -- either [Deep_]Initialize or the type-specific init proc. |
97779c34 AC |
3265 | |
3266 | else | |
0382062b | 3267 | Find_Last_Init (Count_Ins, Body_Ins); |
97779c34 | 3268 | end if; |
df3e68b1 | 3269 | |
1804faa4 AC |
3270 | -- If the Initialize function is null or trivial, the call will have |
3271 | -- been replaced with a null statement, in which case place counter | |
3272 | -- declaration after object declaration itself. | |
3273 | ||
3274 | if No (Count_Ins) then | |
3275 | Count_Ins := Decl; | |
3276 | end if; | |
3277 | ||
df3e68b1 HK |
3278 | Insert_After (Count_Ins, Inc_Decl); |
3279 | Analyze (Inc_Decl); | |
3280 | ||
3281 | -- If the current declaration is the last in the list, the finalizer | |
3282 | -- body needs to be inserted after the set counter statement for the | |
3283 | -- current object declaration. This is complicated by the fact that | |
3284 | -- the set counter statement may appear in abort deferred block. In | |
3285 | -- that case, the proper insertion place is after the block. | |
3286 | ||
3287 | if No (Finalizer_Insert_Nod) then | |
3288 | ||
0691ed6b | 3289 | -- Insertion after an abort deferred block |
df3e68b1 HK |
3290 | |
3291 | if Present (Body_Ins) then | |
3292 | Finalizer_Insert_Nod := Body_Ins; | |
3293 | else | |
3294 | Finalizer_Insert_Nod := Inc_Decl; | |
3295 | end if; | |
3296 | end if; | |
3297 | ||
3298 | -- Create the associated label with this object, generate: | |
4ac2bbbd | 3299 | |
df3e68b1 HK |
3300 | -- L<counter> : label; |
3301 | ||
3302 | Label_Id := | |
cfae2bed | 3303 | Make_Identifier (Loc, New_External_Name ('L', Counter_Val)); |
886b5a18 AC |
3304 | Set_Entity |
3305 | (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id))); | |
df3e68b1 HK |
3306 | Label := Make_Label (Loc, Label_Id); |
3307 | ||
3308 | Prepend_To (Finalizer_Decls, | |
3309 | Make_Implicit_Label_Declaration (Loc, | |
3310 | Defining_Identifier => Entity (Label_Id), | |
cfae2bed | 3311 | Label_Construct => Label)); |
df3e68b1 HK |
3312 | |
3313 | -- Create the associated jump with this object, generate: | |
4b03d946 | 3314 | |
df3e68b1 HK |
3315 | -- when <counter> => |
3316 | -- goto L<counter>; | |
3317 | ||
3318 | Prepend_To (Jump_Alts, | |
3319 | Make_Case_Statement_Alternative (Loc, | |
3320 | Discrete_Choices => New_List ( | |
3321 | Make_Integer_Literal (Loc, Counter_Val)), | |
cfae2bed | 3322 | Statements => New_List ( |
df3e68b1 | 3323 | Make_Goto_Statement (Loc, |
e4494292 | 3324 | Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); |
df3e68b1 HK |
3325 | |
3326 | -- Insert the jump destination, generate: | |
4b03d946 | 3327 | |
df3e68b1 HK |
3328 | -- <<L<counter>>> |
3329 | ||
3330 | Append_To (Finalizer_Stmts, Label); | |
3331 | ||
54c49fcd GL |
3332 | -- Disable warnings on Obj_Id. This works around an issue where GCC |
3333 | -- is not able to detect that Obj_Id is protected by a counter and | |
3334 | -- emits spurious warnings. | |
3335 | ||
3336 | if not Comes_From_Source (Obj_Id) then | |
3337 | Set_Warnings_Off (Obj_Id); | |
3338 | end if; | |
3339 | ||
df3e68b1 HK |
3340 | -- Processing for simple protected objects. Such objects require |
3341 | -- manual finalization of their lock managers. | |
3342 | ||
3343 | if Is_Protected then | |
df3e68b1 | 3344 | if Is_Simple_Protected_Type (Obj_Typ) then |
88f47280 | 3345 | Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref); |
886b5a18 | 3346 | |
88f47280 AC |
3347 | if Present (Fin_Call) then |
3348 | Fin_Stmts := New_List (Fin_Call); | |
3349 | end if; | |
df3e68b1 HK |
3350 | |
3351 | elsif Has_Simple_Protected_Object (Obj_Typ) then | |
3352 | if Is_Record_Type (Obj_Typ) then | |
3353 | Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ); | |
df3e68b1 HK |
3354 | elsif Is_Array_Type (Obj_Typ) then |
3355 | Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ); | |
3356 | end if; | |
3357 | end if; | |
3358 | ||
3359 | -- Generate: | |
3360 | -- begin | |
3361 | -- System.Tasking.Protected_Objects.Finalize_Protection | |
3362 | -- (Obj._object); | |
886b5a18 | 3363 | |
df3e68b1 HK |
3364 | -- exception |
3365 | -- when others => | |
3366 | -- null; | |
3367 | -- end; | |
3368 | ||
321c24f7 AC |
3369 | if Present (Fin_Stmts) and then Exceptions_OK then |
3370 | Fin_Stmts := New_List ( | |
df3e68b1 HK |
3371 | Make_Block_Statement (Loc, |
3372 | Handled_Statement_Sequence => | |
3373 | Make_Handled_Sequence_Of_Statements (Loc, | |
cfae2bed | 3374 | Statements => Fin_Stmts, |
df3e68b1 HK |
3375 | |
3376 | Exception_Handlers => New_List ( | |
3377 | Make_Exception_Handler (Loc, | |
3378 | Exception_Choices => New_List ( | |
3379 | Make_Others_Choice (Loc)), | |
3380 | ||
cfae2bed | 3381 | Statements => New_List ( |
df3e68b1 HK |
3382 | Make_Null_Statement (Loc))))))); |
3383 | end if; | |
3384 | ||
3385 | -- Processing for regular controlled objects | |
3386 | ||
3387 | else | |
3388 | -- Generate: | |
7bf911b5 | 3389 | -- begin |
df3e68b1 | 3390 | -- [Deep_]Finalize (Obj); |
886b5a18 | 3391 | |
df3e68b1 HK |
3392 | -- exception |
3393 | -- when Id : others => | |
3394 | -- if not Raised then | |
3395 | -- Raised := True; | |
3396 | -- Save_Occurrence (E, Id); | |
3397 | -- end if; | |
3398 | -- end; | |
3399 | ||
3400 | Fin_Call := | |
3401 | Make_Final_Call ( | |
3402 | Obj_Ref => Obj_Ref, | |
3403 | Typ => Obj_Typ); | |
3404 | ||
2168d7cc AC |
3405 | -- Guard against a missing [Deep_]Finalize when the object type |
3406 | -- was not properly frozen. | |
3407 | ||
3408 | if No (Fin_Call) then | |
3409 | Fin_Call := Make_Null_Statement (Loc); | |
3410 | end if; | |
3411 | ||
e6807723 AC |
3412 | -- For CodePeer, the exception handlers normally generated here |
3413 | -- generate complex flowgraphs which result in capacity problems. | |
3414 | -- Omitting these handlers for CodePeer is justified as follows: | |
3415 | ||
3416 | -- If a handler is dead, then omitting it is surely ok | |
3417 | ||
3418 | -- If a handler is live, then CodePeer should flag the | |
3419 | -- potentially-exception-raising construct that causes it | |
3420 | -- to be live. That is what we are interested in, not what | |
3421 | -- happens after the exception is raised. | |
3422 | ||
3423 | if Exceptions_OK and not CodePeer_Mode then | |
df3e68b1 HK |
3424 | Fin_Stmts := New_List ( |
3425 | Make_Block_Statement (Loc, | |
3426 | Handled_Statement_Sequence => | |
3427 | Make_Handled_Sequence_Of_Statements (Loc, | |
3428 | Statements => New_List (Fin_Call), | |
3429 | ||
3430 | Exception_Handlers => New_List ( | |
3431 | Build_Exception_Handler | |
36b8f95f | 3432 | (Finalizer_Data, For_Package))))); |
df3e68b1 HK |
3433 | |
3434 | -- When exception handlers are prohibited, the finalization call | |
3435 | -- appears unprotected. Any exception raised during finalization | |
3436 | -- will bypass the circuitry which ensures the cleanup of all | |
3437 | -- remaining objects. | |
3438 | ||
3439 | else | |
3440 | Fin_Stmts := New_List (Fin_Call); | |
3441 | end if; | |
3442 | ||
3443 | -- If we are dealing with a return object of a build-in-place | |
3444 | -- function, generate the following cleanup statements: | |
886b5a18 | 3445 | |
d3f70b35 AC |
3446 | -- if BIPallocfrom > Secondary_Stack'Pos |
3447 | -- and then BIPfinalizationmaster /= null | |
3448 | -- then | |
df3e68b1 HK |
3449 | -- declare |
3450 | -- type Ptr_Typ is access Obj_Typ; | |
3451 | -- for Ptr_Typ'Storage_Pool use | |
d3f70b35 | 3452 | -- Base_Pool (BIPfinalizationmaster.all).all; |
df3e68b1 HK |
3453 | -- begin |
3454 | -- Free (Ptr_Typ (Temp)); | |
3455 | -- end; | |
3456 | -- end if; | |
4b03d946 | 3457 | |
df3e68b1 | 3458 | -- The generated code effectively detaches the temporary from the |
535a8637 | 3459 | -- caller finalization master and deallocates the object. |
df3e68b1 | 3460 | |
535a8637 | 3461 | if Is_Return_Object (Obj_Id) then |
df3e68b1 HK |
3462 | declare |
3463 | Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); | |
df3e68b1 HK |
3464 | begin |
3465 | if Is_Build_In_Place_Function (Func_Id) | |
d3f70b35 | 3466 | and then Needs_BIP_Finalization_Master (Func_Id) |
df3e68b1 | 3467 | then |
0382062b | 3468 | Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); |
df3e68b1 HK |
3469 | end if; |
3470 | end; | |
3471 | end if; | |
3472 | ||
4a08c95c | 3473 | if Ekind (Obj_Id) in E_Constant | E_Variable |
3cebd1c0 | 3474 | and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) |
df3e68b1 | 3475 | then |
35a1c212 | 3476 | -- Temporaries created for the purpose of "exporting" a |
937e9676 | 3477 | -- transient object out of an Expression_With_Actions (EWA) |
35a1c212 AC |
3478 | -- need guards. The following illustrates the usage of such |
3479 | -- temporaries. | |
3480 | ||
3481 | -- Access_Typ : access [all] Obj_Typ; | |
3482 | -- Temp : Access_Typ := null; | |
3483 | -- <Counter> := ...; | |
3484 | ||
3485 | -- do | |
3486 | -- Ctrl_Trans : [access [all]] Obj_Typ := ...; | |
3487 | -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer | |
3488 | -- <or> | |
3489 | -- Temp := Ctrl_Trans'Unchecked_Access; | |
3490 | -- in ... end; | |
3491 | ||
3492 | -- The finalization machinery does not process EWA nodes as | |
3493 | -- this may lead to premature finalization of expressions. Note | |
3494 | -- that Temp is marked as being properly initialized regardless | |
3495 | -- of whether the initialization of Ctrl_Trans succeeded. Since | |
3496 | -- a failed initialization may leave Temp with a value of null, | |
3497 | -- add a guard to handle this case: | |
3498 | ||
3499 | -- if Obj /= null then | |
3500 | -- <object finalization statements> | |
3501 | -- end if; | |
df3e68b1 | 3502 | |
3cebd1c0 | 3503 | if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = |
2a290fec | 3504 | N_Object_Declaration |
3cebd1c0 | 3505 | then |
35a1c212 AC |
3506 | Fin_Stmts := New_List ( |
3507 | Make_If_Statement (Loc, | |
3508 | Condition => | |
3509 | Make_Op_Ne (Loc, | |
e4494292 | 3510 | Left_Opnd => New_Occurrence_Of (Obj_Id, Loc), |
35a1c212 | 3511 | Right_Opnd => Make_Null (Loc)), |
35a1c212 | 3512 | Then_Statements => Fin_Stmts)); |
3cebd1c0 | 3513 | |
2a290fec AC |
3514 | -- Return objects use a flag to aid in processing their |
3515 | -- potential finalization when the enclosing function fails | |
3516 | -- to return properly. Generate: | |
3cebd1c0 AC |
3517 | |
3518 | -- if not Flag then | |
3519 | -- <object finalization statements> | |
3520 | -- end if; | |
3521 | ||
3522 | else | |
3523 | Fin_Stmts := New_List ( | |
3524 | Make_If_Statement (Loc, | |
3525 | Condition => | |
3526 | Make_Op_Not (Loc, | |
3527 | Right_Opnd => | |
e4494292 | 3528 | New_Occurrence_Of |
3cebd1c0 AC |
3529 | (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)), |
3530 | ||
3531 | Then_Statements => Fin_Stmts)); | |
35a1c212 | 3532 | end if; |
df3e68b1 HK |
3533 | end if; |
3534 | end if; | |
3535 | ||
3536 | Append_List_To (Finalizer_Stmts, Fin_Stmts); | |
3537 | ||
3538 | -- Since the declarations are examined in reverse, the state counter | |
cfae2bed | 3539 | -- must be decremented in order to keep with the true position of |
df3e68b1 HK |
3540 | -- objects. |
3541 | ||
3542 | Counter_Val := Counter_Val - 1; | |
3543 | end Process_Object_Declaration; | |
3544 | ||
26e7e1a0 AC |
3545 | ------------------------------------- |
3546 | -- Process_Tagged_Type_Declaration -- | |
3547 | ------------------------------------- | |
3548 | ||
3549 | procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is | |
3550 | Typ : constant Entity_Id := Defining_Identifier (Decl); | |
3551 | DT_Ptr : constant Entity_Id := | |
3552 | Node (First_Elmt (Access_Disp_Table (Typ))); | |
3553 | begin | |
3554 | -- Generate: | |
3555 | -- Ada.Tags.Unregister_Tag (<Typ>P); | |
3556 | ||
3557 | Append_To (Tagged_Type_Stmts, | |
3558 | Make_Procedure_Call_Statement (Loc, | |
886b5a18 | 3559 | Name => |
e4494292 | 3560 | New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc), |
26e7e1a0 | 3561 | Parameter_Associations => New_List ( |
e4494292 | 3562 | New_Occurrence_Of (DT_Ptr, Loc)))); |
26e7e1a0 AC |
3563 | end Process_Tagged_Type_Declaration; |
3564 | ||
a1023434 | 3565 | -- Start of processing for Build_Finalizer_Helper |
df3e68b1 HK |
3566 | |
3567 | begin | |
3568 | Fin_Id := Empty; | |
3569 | ||
06b599fd | 3570 | -- Do not perform this expansion in SPARK mode because it is not |
2bfa5484 HK |
3571 | -- necessary. |
3572 | ||
f5da7a97 | 3573 | if GNATprove_Mode then |
2bfa5484 HK |
3574 | return; |
3575 | end if; | |
3576 | ||
26e7e1a0 AC |
3577 | -- Step 1: Extract all lists which may contain controlled objects or |
3578 | -- library-level tagged types. | |
df3e68b1 HK |
3579 | |
3580 | if For_Package_Spec then | |
3581 | Decls := Visible_Declarations (Specification (N)); | |
3582 | Priv_Decls := Private_Declarations (Specification (N)); | |
3583 | ||
3584 | -- Retrieve the package spec id | |
3585 | ||
3586 | Spec_Id := Defining_Unit_Name (Specification (N)); | |
3587 | ||
3588 | if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then | |
3589 | Spec_Id := Defining_Identifier (Spec_Id); | |
3590 | end if; | |
3591 | ||
3592 | -- Accept statement, block, entry body, package body, protected body, | |
3593 | -- subprogram body or task body. | |
3594 | ||
3595 | else | |
3596 | Decls := Declarations (N); | |
3597 | HSS := Handled_Statement_Sequence (N); | |
3598 | ||
3599 | if Present (HSS) then | |
3600 | if Present (Statements (HSS)) then | |
3601 | Stmts := Statements (HSS); | |
3602 | end if; | |
3603 | ||
3604 | if Present (At_End_Proc (HSS)) then | |
3605 | Prev_At_End := At_End_Proc (HSS); | |
3606 | end if; | |
3607 | end if; | |
3608 | ||
3609 | -- Retrieve the package spec id for package bodies | |
3610 | ||
3611 | if For_Package_Body then | |
3612 | Spec_Id := Corresponding_Spec (N); | |
3613 | end if; | |
3614 | end if; | |
3615 | ||
3616 | -- Do not process nested packages since those are handled by the | |
3617 | -- enclosing scope's finalizer. Do not process non-expanded package | |
3618 | -- instantiations since those will be re-analyzed and re-expanded. | |
3619 | ||
3620 | if For_Package | |
3621 | and then | |
3622 | (not Is_Library_Level_Entity (Spec_Id) | |
3623 | ||
41c79d60 AC |
3624 | -- Nested packages are considered to be library level entities, |
3625 | -- but do not need to be processed separately. True library level | |
3626 | -- packages have a scope value of 1. | |
df3e68b1 | 3627 | |
41c79d60 AC |
3628 | or else Scope_Depth_Value (Spec_Id) /= Uint_1 |
3629 | or else (Is_Generic_Instance (Spec_Id) | |
3630 | and then Package_Instantiation (Spec_Id) /= N)) | |
213c9dc7 AC |
3631 | |
3632 | -- Still need to process package body instantiations which may | |
3633 | -- contain objects requiring finalization. | |
3634 | ||
3635 | and then not | |
3636 | (For_Package_Body | |
3637 | and then Is_Library_Level_Entity (Spec_Id) | |
3638 | and then Is_Generic_Instance (Spec_Id)) | |
df3e68b1 HK |
3639 | then |
3640 | return; | |
3641 | end if; | |
3642 | ||
3643 | -- Step 2: Object [pre]processing | |
3644 | ||
3645 | if For_Package then | |
3646 | ||
3647 | -- Preprocess the visible declarations now in order to obtain the | |
3648 | -- correct number of controlled object by the time the private | |
3649 | -- declarations are processed. | |
3650 | ||
3651 | Process_Declarations (Decls, Preprocess => True, Top_Level => True); | |
3652 | ||
3653 | -- From all the possible contexts, only package specifications may | |
3654 | -- have private declarations. | |
3655 | ||
3656 | if For_Package_Spec then | |
3657 | Process_Declarations | |
3658 | (Priv_Decls, Preprocess => True, Top_Level => True); | |
87729e5a | 3659 | end if; |
df3e68b1 | 3660 | |
87729e5a AC |
3661 | -- The current context may lack controlled objects, but require some |
3662 | -- other form of completion (task termination for instance). In such | |
3663 | -- cases, the finalizer must be created and carry the additional | |
3664 | -- statements. | |
df3e68b1 | 3665 | |
0319cacc | 3666 | if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then |
87729e5a | 3667 | Build_Components; |
df3e68b1 HK |
3668 | end if; |
3669 | ||
26e7e1a0 AC |
3670 | -- The preprocessing has determined that the context has controlled |
3671 | -- objects or library-level tagged types. | |
87729e5a | 3672 | |
0319cacc AC |
3673 | if Has_Ctrl_Objs or Has_Tagged_Types then |
3674 | ||
87729e5a AC |
3675 | -- Private declarations are processed first in order to preserve |
3676 | -- possible dependencies between public and private objects. | |
3677 | ||
3678 | if For_Package_Spec then | |
3679 | Process_Declarations (Priv_Decls); | |
3680 | end if; | |
3681 | ||
df3e68b1 HK |
3682 | Process_Declarations (Decls); |
3683 | end if; | |
3684 | ||
3685 | -- Non-package case | |
3686 | ||
3687 | else | |
3688 | -- Preprocess both declarations and statements | |
3689 | ||
3690 | Process_Declarations (Decls, Preprocess => True, Top_Level => True); | |
3691 | Process_Declarations (Stmts, Preprocess => True, Top_Level => True); | |
3692 | ||
3693 | -- At this point it is known that N has controlled objects. Ensure | |
3694 | -- that N has a declarative list since the finalizer spec will be | |
3695 | -- attached to it. | |
3696 | ||
cfae2bed | 3697 | if Has_Ctrl_Objs and then No (Decls) then |
df3e68b1 HK |
3698 | Set_Declarations (N, New_List); |
3699 | Decls := Declarations (N); | |
3700 | Spec_Decls := Decls; | |
3701 | end if; | |
3702 | ||
3703 | -- The current context may lack controlled objects, but require some | |
3704 | -- other form of completion (task termination for instance). In such | |
3705 | -- cases, the finalizer must be created and carry the additional | |
3706 | -- statements. | |
3707 | ||
0319cacc | 3708 | if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then |
df3e68b1 HK |
3709 | Build_Components; |
3710 | end if; | |
3711 | ||
0319cacc | 3712 | if Has_Ctrl_Objs or Has_Tagged_Types then |
df3e68b1 HK |
3713 | Process_Declarations (Stmts); |
3714 | Process_Declarations (Decls); | |
3715 | end if; | |
3716 | end if; | |
3717 | ||
3718 | -- Step 3: Finalizer creation | |
3719 | ||
213c9dc7 | 3720 | if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then |
df3e68b1 HK |
3721 | Create_Finalizer; |
3722 | end if; | |
a1023434 | 3723 | end Build_Finalizer_Helper; |
df3e68b1 HK |
3724 | |
3725 | -------------------------- | |
3726 | -- Build_Finalizer_Call -- | |
3727 | -------------------------- | |
3728 | ||
3729 | procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is | |
df3e68b1 HK |
3730 | Is_Prot_Body : constant Boolean := |
3731 | Nkind (N) = N_Subprogram_Body | |
3732 | and then Is_Protected_Subprogram_Body (N); | |
3733 | -- Determine whether N denotes the protected version of a subprogram | |
3734 | -- which belongs to a protected type. | |
3735 | ||
f849ad6f | 3736 | Loc : constant Source_Ptr := Sloc (N); |
37da997b | 3737 | HSS : Node_Id; |
6d9e03cb | 3738 | |
df3e68b1 | 3739 | begin |
06b599fd | 3740 | -- Do not perform this expansion in SPARK mode because we do not create |
2bfa5484 HK |
3741 | -- finalizers in the first place. |
3742 | ||
f5da7a97 | 3743 | if GNATprove_Mode then |
2bfa5484 HK |
3744 | return; |
3745 | end if; | |
3746 | ||
df3e68b1 HK |
3747 | -- The At_End handler should have been assimilated by the finalizer |
3748 | ||
37da997b | 3749 | HSS := Handled_Statement_Sequence (N); |
df3e68b1 HK |
3750 | pragma Assert (No (At_End_Proc (HSS))); |
3751 | ||
3752 | -- If the construct to be cleaned up is a protected subprogram body, the | |
3753 | -- finalizer call needs to be associated with the block which wraps the | |
3754 | -- unprotected version of the subprogram. The following illustrates this | |
3755 | -- scenario: | |
886b5a18 | 3756 | |
df3e68b1 HK |
3757 | -- procedure Prot_SubpP is |
3758 | -- procedure finalizer is | |
3759 | -- begin | |
3760 | -- Service_Entries (Prot_Obj); | |
3761 | -- Abort_Undefer; | |
3762 | -- end finalizer; | |
886b5a18 | 3763 | |
df3e68b1 HK |
3764 | -- begin |
3765 | -- . . . | |
3766 | -- begin | |
3767 | -- Prot_SubpN (Prot_Obj); | |
3768 | -- at end | |
3769 | -- finalizer; | |
3770 | -- end; | |
3771 | -- end Prot_SubpP; | |
3772 | ||
3773 | if Is_Prot_Body then | |
3774 | HSS := Handled_Statement_Sequence (Last (Statements (HSS))); | |
3775 | ||
3776 | -- An At_End handler and regular exception handlers cannot coexist in | |
3777 | -- the same statement sequence. Wrap the original statements in a block. | |
3778 | ||
3779 | elsif Present (Exception_Handlers (HSS)) then | |
3780 | declare | |
3781 | End_Lab : constant Node_Id := End_Label (HSS); | |
3782 | Block : Node_Id; | |
3783 | ||
3784 | begin | |
3785 | Block := | |
cfae2bed | 3786 | Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); |
df3e68b1 HK |
3787 | |
3788 | Set_Handled_Statement_Sequence (N, | |
3789 | Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); | |
3790 | ||
3791 | HSS := Handled_Statement_Sequence (N); | |
3792 | Set_End_Label (HSS, End_Lab); | |
3793 | end; | |
3794 | end if; | |
3795 | ||
e4494292 | 3796 | Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc)); |
df3e68b1 | 3797 | |
795d0063 | 3798 | -- Attach reference to finalizer to tree, for LLVM use |
f537fc00 | 3799 | |
795d0063 ES |
3800 | Set_Parent (At_End_Proc (HSS), HSS); |
3801 | ||
df3e68b1 HK |
3802 | Analyze (At_End_Proc (HSS)); |
3803 | Expand_At_End_Handler (HSS, Empty); | |
3804 | end Build_Finalizer_Call; | |
3805 | ||
a1023434 JS |
3806 | --------------------- |
3807 | -- Build_Finalizer -- | |
3808 | --------------------- | |
3809 | ||
3810 | procedure Build_Finalizer | |
3811 | (N : Node_Id; | |
3812 | Clean_Stmts : List_Id; | |
3813 | Mark_Id : Entity_Id; | |
3814 | Top_Decls : List_Id; | |
3815 | Defer_Abort : Boolean; | |
3816 | Fin_Id : out Entity_Id) | |
3817 | is | |
3818 | Def_Ent : constant Entity_Id := Unique_Defining_Entity (N); | |
3819 | Loc : constant Source_Ptr := Sloc (N); | |
3820 | ||
3821 | -- Declarations used for the creation of _finalization_controller | |
3822 | ||
3823 | Fin_Old_Id : Entity_Id := Empty; | |
3824 | Fin_Controller_Id : Entity_Id := Empty; | |
3825 | Fin_Controller_Decls : List_Id; | |
3826 | Fin_Controller_Stmts : List_Id; | |
3827 | Fin_Controller_Body : Node_Id := Empty; | |
3828 | Fin_Controller_Spec : Node_Id := Empty; | |
3829 | Postconditions_Call : Node_Id := Empty; | |
3830 | ||
3831 | -- Defining identifiers for local objects used to store exception info | |
3832 | ||
3833 | Raised_Post_Exception_Id : Entity_Id := Empty; | |
3834 | Raised_Finalization_Exception_Id : Entity_Id := Empty; | |
3835 | Saved_Exception_Id : Entity_Id := Empty; | |
3836 | ||
3837 | -- Start of processing for Build_Finalizer | |
3838 | ||
3839 | begin | |
3840 | -- Create the general finalization routine | |
3841 | ||
3842 | Build_Finalizer_Helper | |
3843 | (N => N, | |
3844 | Clean_Stmts => Clean_Stmts, | |
3845 | Mark_Id => Mark_Id, | |
3846 | Top_Decls => Top_Decls, | |
3847 | Defer_Abort => Defer_Abort, | |
3848 | Fin_Id => Fin_Id, | |
3849 | Finalize_Old_Only => False); | |
3850 | ||
3851 | -- When postconditions are present, expansion gets much more complicated | |
3852 | -- due to both the fact that they must be called after finalization and | |
3853 | -- that finalization of 'Old objects must occur after the postconditions | |
3854 | -- get checked. | |
3855 | ||
3856 | -- Additionally, exceptions between general finalization and 'Old | |
3857 | -- finalization must be propagated correctly and exceptions which happen | |
3858 | -- during _postconditions need to be saved and reraised after | |
3859 | -- finalization of 'Old objects. | |
3860 | ||
3861 | -- Generate: | |
3862 | -- | |
3863 | -- Postcond_Enabled := False; | |
3864 | -- | |
3865 | -- procedure _finalization_controller is | |
3866 | -- | |
3867 | -- -- Exception capturing and tracking | |
3868 | -- | |
3869 | -- Saved_Exception : Exception_Occurrence; | |
3870 | -- Raised_Post_Exception : Boolean := False; | |
3871 | -- Raised_Finalization_Exception : Boolean := False; | |
3872 | -- | |
3873 | -- -- Start of processing for _finalization_controller | |
3874 | -- | |
3875 | -- begin | |
3876 | -- -- Perform general finalization | |
3877 | -- | |
3878 | -- begin | |
3879 | -- _finalizer; | |
3880 | -- exception | |
3881 | -- when others => | |
3882 | -- -- Save the exception | |
3883 | -- | |
3884 | -- Raised_Finalization_Exception := True; | |
3885 | -- Save_Occurrence | |
3886 | -- (Saved_Exception, Get_Current_Excep.all); | |
3887 | -- end; | |
3888 | -- | |
3889 | -- -- Perform postcondition checks after general finalization, but | |
3890 | -- -- before finalization of 'Old related objects. | |
3891 | -- | |
3ffe57d4 JS |
3892 | -- if not Raised_Finalization_Exception |
3893 | -- and then Return_Success_For_Postcond | |
3894 | -- then | |
a1023434 JS |
3895 | -- begin |
3896 | -- -- Re-enable postconditions and check them | |
3897 | -- | |
3898 | -- Postcond_Enabled := True; | |
3899 | -- _postconditions [(Result_Obj_For_Postcond[.all])]; | |
3900 | -- exception | |
3901 | -- when others => | |
3902 | -- -- Save the exception | |
3903 | -- | |
3904 | -- Raised_Post_Exception := True; | |
3905 | -- Save_Occurrence | |
3906 | -- (Saved_Exception, Get_Current_Excep.all); | |
3907 | -- end; | |
3908 | -- end if; | |
3909 | -- | |
3910 | -- -- Finally finalize 'Old related objects | |
3911 | -- | |
3912 | -- begin | |
3913 | -- _finalizer_old; | |
3914 | -- exception | |
3915 | -- when others => | |
3916 | -- -- Reraise the previous finalization error if there is | |
3917 | -- -- one. | |
3918 | -- | |
3919 | -- if Raised_Finalization_Exception then | |
3920 | -- Reraise_Occurrence (Saved_Exception); | |
3921 | -- end if; | |
3922 | -- | |
3923 | -- -- Otherwise, reraise the current one | |
3924 | -- | |
3925 | -- raise; | |
3926 | -- end; | |
3927 | -- | |
3928 | -- -- Reraise any saved exception | |
3929 | -- | |
3930 | -- if Raised_Finalization_Exception | |
3931 | -- or else Raised_Post_Exception | |
3932 | -- then | |
3933 | -- Reraise_Occurrence (Saved_Exception); | |
3934 | -- end if; | |
3935 | -- end _finalization_controller; | |
3936 | ||
3937 | if Nkind (N) = N_Subprogram_Body | |
3938 | and then Present (Postconditions_Proc (Def_Ent)) | |
3939 | then | |
3940 | Fin_Controller_Stmts := New_List; | |
3941 | Fin_Controller_Decls := New_List; | |
3942 | ||
3943 | -- Build the 'Old finalizer | |
3944 | ||
3945 | Build_Finalizer_Helper | |
3946 | (N => N, | |
3947 | Clean_Stmts => Empty_List, | |
3948 | Mark_Id => Mark_Id, | |
3949 | Top_Decls => Top_Decls, | |
3950 | Defer_Abort => Defer_Abort, | |
3951 | Fin_Id => Fin_Old_Id, | |
3952 | Finalize_Old_Only => True); | |
3953 | ||
3954 | -- Create local declarations for _finalization_controller needed for | |
3955 | -- saving exceptions. | |
3956 | -- | |
3957 | -- Generate: | |
3958 | -- | |
3959 | -- Saved_Exception : Exception_Occurrence; | |
3960 | -- Raised_Post_Exception : Boolean := False; | |
3961 | -- Raised_Finalization_Exception : Boolean := False; | |
3962 | ||
3963 | Saved_Exception_Id := Make_Temporary (Loc, 'S'); | |
3964 | Raised_Post_Exception_Id := Make_Temporary (Loc, 'P'); | |
3965 | Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F'); | |
3966 | ||
3967 | Append_List_To (Fin_Controller_Decls, New_List ( | |
3968 | Make_Object_Declaration (Loc, | |
3969 | Defining_Identifier => Saved_Exception_Id, | |
3970 | Object_Definition => | |
3971 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)), | |
3972 | Make_Object_Declaration (Loc, | |
3973 | Defining_Identifier => Raised_Post_Exception_Id, | |
3974 | Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), | |
3975 | Expression => New_Occurrence_Of (Standard_False, Loc)), | |
3976 | Make_Object_Declaration (Loc, | |
3977 | Defining_Identifier => Raised_Finalization_Exception_Id, | |
3978 | Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), | |
3979 | Expression => New_Occurrence_Of (Standard_False, Loc)))); | |
3980 | ||
3981 | -- Call _finalizer and save any exceptions which occur | |
3982 | ||
3983 | -- Generate: | |
3984 | -- | |
3985 | -- begin | |
3986 | -- _finalizer; | |
3987 | -- exception | |
3988 | -- when others => | |
3989 | -- Raised_Finalization_Exception := True; | |
3990 | -- Save_Occurrence | |
3991 | -- (Saved_Exception, Get_Current_Excep.all); | |
3992 | -- end; | |
3993 | ||
3994 | if Present (Fin_Id) then | |
3995 | Append_To (Fin_Controller_Stmts, | |
3996 | Make_Block_Statement (Loc, | |
3997 | Handled_Statement_Sequence => | |
3998 | Make_Handled_Sequence_Of_Statements (Loc, | |
3999 | Statements => New_List ( | |
4000 | Make_Procedure_Call_Statement (Loc, | |
4001 | Name => New_Occurrence_Of (Fin_Id, Loc))), | |
4002 | Exception_Handlers => New_List ( | |
4003 | Make_Exception_Handler (Loc, | |
4004 | Exception_Choices => New_List ( | |
4005 | Make_Others_Choice (Loc)), | |
4006 | Statements => New_List ( | |
4007 | Make_Assignment_Statement (Loc, | |
4008 | Name => | |
4009 | New_Occurrence_Of | |
4010 | (Raised_Finalization_Exception_Id, Loc), | |
4011 | Expression => | |
4012 | New_Occurrence_Of (Standard_True, Loc)), | |
4013 | Make_Procedure_Call_Statement (Loc, | |
4014 | Name => | |
4015 | New_Occurrence_Of | |
4016 | (RTE (RE_Save_Occurrence), Loc), | |
4017 | Parameter_Associations => New_List ( | |
4018 | New_Occurrence_Of | |
4019 | (Saved_Exception_Id, Loc), | |
4020 | Make_Explicit_Dereference (Loc, | |
4021 | Prefix => | |
4022 | Make_Function_Call (Loc, | |
4023 | Name => | |
4024 | Make_Explicit_Dereference (Loc, | |
4025 | Prefix => | |
4026 | New_Occurrence_Of | |
4027 | (RTE (RE_Get_Current_Excep), | |
4028 | Loc)))))))))))); | |
4029 | end if; | |
4030 | ||
4031 | -- Create the call to postconditions based on the kind of the current | |
4032 | -- subprogram, and the type of the Result_Obj_For_Postcond. | |
4033 | ||
4034 | -- Generate: | |
4035 | -- | |
4036 | -- _postconditions (Result_Obj_For_Postcond[.all]); | |
4037 | -- | |
4038 | -- or | |
4039 | -- | |
4040 | -- _postconditions; | |
4041 | ||
4042 | if Ekind (Def_Ent) = E_Procedure then | |
4043 | Postconditions_Call := | |
4044 | Make_Procedure_Call_Statement (Loc, | |
4045 | Name => | |
4046 | New_Occurrence_Of | |
4047 | (Postconditions_Proc (Def_Ent), Loc)); | |
4048 | else | |
4049 | Postconditions_Call := | |
4050 | Make_Procedure_Call_Statement (Loc, | |
4051 | Name => | |
4052 | New_Occurrence_Of | |
4053 | (Postconditions_Proc (Def_Ent), Loc), | |
4054 | Parameter_Associations => New_List ( | |
4055 | (if Is_Elementary_Type (Etype (Def_Ent)) then | |
4056 | New_Occurrence_Of | |
4057 | (Get_Result_Object_For_Postcond | |
4058 | (Def_Ent), Loc) | |
4059 | else | |
4060 | Make_Explicit_Dereference (Loc, | |
4061 | New_Occurrence_Of | |
4062 | (Get_Result_Object_For_Postcond | |
4063 | (Def_Ent), Loc))))); | |
4064 | end if; | |
4065 | ||
4066 | -- Call _postconditions when no general finalization exceptions have | |
4067 | -- occured taking care to enable the postconditions and save any | |
4068 | -- exception occurrences. | |
4069 | ||
4070 | -- Generate: | |
4071 | -- | |
3ffe57d4 JS |
4072 | -- if not Raised_Finalization_Exception |
4073 | -- and then Return_Success_For_Postcond | |
4074 | -- then | |
a1023434 JS |
4075 | -- begin |
4076 | -- Postcond_Enabled := True; | |
4077 | -- _postconditions [(Result_Obj_For_Postcond[.all])]; | |
4078 | -- exception | |
4079 | -- when others => | |
4080 | -- Raised_Post_Exception := True; | |
4081 | -- Save_Occurrence | |
4082 | -- (Saved_Exception, Get_Current_Excep.all); | |
4083 | -- end; | |
4084 | -- end if; | |
4085 | ||
4086 | Append_To (Fin_Controller_Stmts, | |
4087 | Make_If_Statement (Loc, | |
4088 | Condition => | |
3ffe57d4 JS |
4089 | Make_And_Then (Loc, |
4090 | Left_Opnd => | |
4091 | Make_Op_Not (Loc, | |
4092 | Right_Opnd => | |
4093 | New_Occurrence_Of | |
4094 | (Raised_Finalization_Exception_Id, Loc)), | |
a1023434 JS |
4095 | Right_Opnd => |
4096 | New_Occurrence_Of | |
3ffe57d4 | 4097 | (Get_Return_Success_For_Postcond (Def_Ent), Loc)), |
a1023434 JS |
4098 | Then_Statements => New_List ( |
4099 | Make_Block_Statement (Loc, | |
4100 | Handled_Statement_Sequence => | |
4101 | Make_Handled_Sequence_Of_Statements (Loc, | |
4102 | Statements => New_List ( | |
4103 | Make_Assignment_Statement (Loc, | |
4104 | Name => | |
4105 | New_Occurrence_Of | |
4106 | (Get_Postcond_Enabled (Def_Ent), Loc), | |
4107 | Expression => | |
4108 | New_Occurrence_Of | |
4109 | (Standard_True, Loc)), | |
4110 | Postconditions_Call), | |
4111 | Exception_Handlers => New_List ( | |
4112 | Make_Exception_Handler (Loc, | |
4113 | Exception_Choices => New_List ( | |
4114 | Make_Others_Choice (Loc)), | |
4115 | Statements => New_List ( | |
4116 | Make_Assignment_Statement (Loc, | |
4117 | Name => | |
4118 | New_Occurrence_Of | |
4119 | (Raised_Post_Exception_Id, Loc), | |
4120 | Expression => | |
4121 | New_Occurrence_Of (Standard_True, Loc)), | |
4122 | Make_Procedure_Call_Statement (Loc, | |
4123 | Name => | |
4124 | New_Occurrence_Of | |
4125 | (RTE (RE_Save_Occurrence), Loc), | |
4126 | Parameter_Associations => New_List ( | |
4127 | New_Occurrence_Of | |
4128 | (Saved_Exception_Id, Loc), | |
4129 | Make_Explicit_Dereference (Loc, | |
4130 | Prefix => | |
4131 | Make_Function_Call (Loc, | |
4132 | Name => | |
4133 | Make_Explicit_Dereference (Loc, | |
4134 | Prefix => | |
4135 | New_Occurrence_Of | |
4136 | (RTE (RE_Get_Current_Excep), | |
4137 | Loc)))))))))))))); | |
4138 | ||
4139 | -- Call _finalizer_old and reraise any exception that occurred during | |
4140 | -- initial finalization within the exception handler. Otherwise, | |
4141 | -- propagate the current exception. | |
4142 | ||
4143 | -- Generate: | |
4144 | -- | |
4145 | -- begin | |
4146 | -- _finalizer_old; | |
4147 | -- exception | |
4148 | -- when others => | |
4149 | -- if Raised_Finalization_Exception then | |
4150 | -- Reraise_Occurrence (Saved_Exception); | |
4151 | -- end if; | |
4152 | -- raise; | |
4153 | -- end; | |
4154 | ||
4155 | if Present (Fin_Old_Id) then | |
4156 | Append_To (Fin_Controller_Stmts, | |
4157 | Make_Block_Statement (Loc, | |
4158 | Handled_Statement_Sequence => | |
4159 | Make_Handled_Sequence_Of_Statements (Loc, | |
4160 | Statements => New_List ( | |
4161 | Make_Procedure_Call_Statement (Loc, | |
4162 | Name => New_Occurrence_Of (Fin_Old_Id, Loc))), | |
4163 | Exception_Handlers => New_List ( | |
4164 | Make_Exception_Handler (Loc, | |
4165 | Exception_Choices => New_List ( | |
4166 | Make_Others_Choice (Loc)), | |
4167 | Statements => New_List ( | |
4168 | Make_If_Statement (Loc, | |
4169 | Condition => | |
4170 | New_Occurrence_Of | |
4171 | (Raised_Finalization_Exception_Id, Loc), | |
4172 | Then_Statements => New_List ( | |
4173 | Make_Procedure_Call_Statement (Loc, | |
4174 | Name => | |
4175 | New_Occurrence_Of | |
4176 | (RTE (RE_Reraise_Occurrence), Loc), | |
4177 | Parameter_Associations => New_List ( | |
4178 | New_Occurrence_Of | |
4179 | (Saved_Exception_Id, Loc))))), | |
4180 | Make_Raise_Statement (Loc))))))); | |
4181 | end if; | |
4182 | ||
4183 | -- Once finalization is complete reraise any pending exceptions | |
4184 | ||
4185 | -- Generate: | |
4186 | -- | |
4187 | -- if Raised_Post_Exception | |
4188 | -- or else Raised_Finalization_Exception | |
4189 | -- then | |
4190 | -- Reraise_Occurrence (Saved_Exception); | |
4191 | -- end if; | |
4192 | ||
4193 | Append_To (Fin_Controller_Stmts, | |
4194 | Make_If_Statement (Loc, | |
4195 | Condition => | |
4196 | Make_Or_Else (Loc, | |
4197 | Left_Opnd => | |
4198 | New_Occurrence_Of | |
4199 | (Raised_Post_Exception_Id, Loc), | |
4200 | Right_Opnd => | |
4201 | New_Occurrence_Of | |
4202 | (Raised_Finalization_Exception_Id, Loc)), | |
4203 | Then_Statements => New_List ( | |
4204 | Make_Procedure_Call_Statement (Loc, | |
4205 | Name => | |
4206 | New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), | |
4207 | Parameter_Associations => New_List ( | |
4208 | New_Occurrence_Of | |
4209 | (Saved_Exception_Id, Loc)))))); | |
4210 | ||
4211 | -- Make the finalization controller subprogram body and declaration. | |
4212 | ||
4213 | -- Generate: | |
4214 | -- procedure _finalization_controller; | |
4215 | -- | |
4216 | -- procedure _finalization_controller is | |
4217 | -- begin | |
4218 | -- [Fin_Controller_Stmts]; | |
4219 | -- end; | |
4220 | ||
4221 | Fin_Controller_Id := | |
4222 | Make_Defining_Identifier (Loc, | |
4223 | Chars => New_External_Name (Name_uFinalization_Controller)); | |
4224 | ||
4225 | Fin_Controller_Spec := | |
4226 | Make_Subprogram_Declaration (Loc, | |
4227 | Specification => | |
4228 | Make_Procedure_Specification (Loc, | |
4229 | Defining_Unit_Name => Fin_Controller_Id)); | |
4230 | ||
4231 | Fin_Controller_Body := | |
4232 | Make_Subprogram_Body (Loc, | |
4233 | Specification => | |
4234 | Make_Procedure_Specification (Loc, | |
4235 | Defining_Unit_Name => | |
4236 | Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))), | |
4237 | Declarations => Fin_Controller_Decls, | |
4238 | Handled_Statement_Sequence => | |
4239 | Make_Handled_Sequence_Of_Statements (Loc, | |
4240 | Statements => Fin_Controller_Stmts)); | |
4241 | ||
4242 | -- Disable _postconditions calls which get generated before return | |
4243 | -- statements to delay their evaluation until after finalization. | |
4244 | ||
4245 | -- This is done by way of the local Postcond_Enabled object which is | |
4246 | -- initially assigned to True - we then create an assignment within | |
4247 | -- the subprogram's declaration to make it False and assign it back | |
4248 | -- to True before _postconditions is called within | |
4249 | -- _finalization_controller. | |
4250 | ||
4251 | -- Generate: | |
4252 | -- | |
4253 | -- Postcond_Enable := False; | |
4254 | ||
4255 | Append_To (Top_Decls, | |
4256 | Make_Assignment_Statement (Loc, | |
4257 | Name => | |
4258 | New_Occurrence_Of | |
4259 | (Get_Postcond_Enabled (Def_Ent), Loc), | |
4260 | Expression => | |
4261 | New_Occurrence_Of | |
4262 | (Standard_False, Loc))); | |
4263 | ||
4264 | -- Add the subprogram to the list of declarations an analyze it | |
4265 | ||
4266 | Append_To (Top_Decls, Fin_Controller_Spec); | |
4267 | Analyze (Fin_Controller_Spec); | |
4268 | Insert_After (Fin_Controller_Spec, Fin_Controller_Body); | |
4269 | Analyze (Fin_Controller_Body, Suppress => All_Checks); | |
4270 | ||
4271 | -- Return the finalization controller as the result Fin_Id | |
4272 | ||
4273 | Fin_Id := Fin_Controller_Id; | |
4274 | end if; | |
4275 | end Build_Finalizer; | |
4276 | ||
df3e68b1 HK |
4277 | --------------------- |
4278 | -- Build_Late_Proc -- | |
4279 | --------------------- | |
4280 | ||
4281 | procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is | |
4282 | begin | |
4283 | for Final_Prim in Name_Of'Range loop | |
4284 | if Name_Of (Final_Prim) = Nam then | |
4285 | Set_TSS (Typ, | |
cfae2bed AC |
4286 | Make_Deep_Proc |
4287 | (Prim => Final_Prim, | |
4288 | Typ => Typ, | |
4289 | Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); | |
df3e68b1 HK |
4290 | end if; |
4291 | end loop; | |
4292 | end Build_Late_Proc; | |
4293 | ||
4294 | ------------------------------- | |
4295 | -- Build_Object_Declarations -- | |
4296 | ------------------------------- | |
4297 | ||
36b8f95f AC |
4298 | procedure Build_Object_Declarations |
4299 | (Data : out Finalization_Exception_Data; | |
4300 | Decls : List_Id; | |
4301 | Loc : Source_Ptr; | |
4302 | For_Package : Boolean := False) | |
df3e68b1 | 4303 | is |
e2bc5465 AC |
4304 | Decl : Node_Id; |
4305 | ||
4306 | Dummy : Entity_Id; | |
e2bc5465 AC |
4307 | -- This variable captures an unused dummy internal entity, see the |
4308 | -- comment associated with its use. | |
df3e68b1 HK |
4309 | |
4310 | begin | |
36b8f95f AC |
4311 | pragma Assert (Decls /= No_List); |
4312 | ||
2d1debf8 AC |
4313 | -- Always set the proper location as it may be needed even when |
4314 | -- exception propagation is forbidden. | |
4315 | ||
4316 | Data.Loc := Loc; | |
4317 | ||
df3e68b1 | 4318 | if Restriction_Active (No_Exception_Propagation) then |
2d1debf8 AC |
4319 | Data.Abort_Id := Empty; |
4320 | Data.E_Id := Empty; | |
36b8f95f AC |
4321 | Data.Raised_Id := Empty; |
4322 | return; | |
df3e68b1 HK |
4323 | end if; |
4324 | ||
36b8f95f | 4325 | Data.Raised_Id := Make_Temporary (Loc, 'R'); |
824e9320 AC |
4326 | |
4327 | -- In certain scenarios, finalization can be triggered by an abort. If | |
4328 | -- the finalization itself fails and raises an exception, the resulting | |
4329 | -- Program_Error must be supressed and replaced by an abort signal. In | |
4330 | -- order to detect this scenario, save the state of entry into the | |
4331 | -- finalization code. | |
f9ad6b62 | 4332 | |
e2bc5465 AC |
4333 | -- This is not needed for library-level finalizers as they are called by |
4334 | -- the environment task and cannot be aborted. | |
276e7ed0 | 4335 | |
535a8637 | 4336 | if not For_Package then |
e2bc5465 AC |
4337 | if Abort_Allowed then |
4338 | Data.Abort_Id := Make_Temporary (Loc, 'A'); | |
23adb371 | 4339 | |
e2bc5465 AC |
4340 | -- Generate: |
4341 | -- Abort_Id : constant Boolean := <A_Expr>; | |
824e9320 | 4342 | |
e2bc5465 AC |
4343 | Append_To (Decls, |
4344 | Make_Object_Declaration (Loc, | |
4345 | Defining_Identifier => Data.Abort_Id, | |
4346 | Constant_Present => True, | |
4347 | Object_Definition => | |
4348 | New_Occurrence_Of (Standard_Boolean, Loc), | |
4349 | Expression => | |
4350 | New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc))); | |
799d0e05 | 4351 | |
e2bc5465 | 4352 | -- Abort is not required |
23adb371 | 4353 | |
e2bc5465 AC |
4354 | else |
4355 | -- Generate a dummy entity to ensure that the internal symbols are | |
4356 | -- in sync when a unit is compiled with and without aborts. | |
f9ad6b62 | 4357 | |
e2bc5465 AC |
4358 | Dummy := Make_Temporary (Loc, 'A'); |
4359 | Data.Abort_Id := Empty; | |
4360 | end if; | |
23adb371 | 4361 | |
535a8637 | 4362 | -- Library-level finalizers |
e2bc5465 AC |
4363 | |
4364 | else | |
4365 | Data.Abort_Id := Empty; | |
f9ad6b62 AC |
4366 | end if; |
4367 | ||
23adb371 | 4368 | if Exception_Extra_Info then |
e2bc5465 | 4369 | Data.E_Id := Make_Temporary (Loc, 'E'); |
824e9320 | 4370 | |
23adb371 AC |
4371 | -- Generate: |
4372 | -- E_Id : Exception_Occurrence; | |
824e9320 | 4373 | |
e2bc5465 | 4374 | Decl := |
23adb371 AC |
4375 | Make_Object_Declaration (Loc, |
4376 | Defining_Identifier => Data.E_Id, | |
4377 | Object_Definition => | |
e4494292 | 4378 | New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)); |
e2bc5465 | 4379 | Set_No_Initialization (Decl); |
f9ad6b62 | 4380 | |
e2bc5465 | 4381 | Append_To (Decls, Decl); |
df3e68b1 | 4382 | |
23adb371 | 4383 | else |
e2bc5465 | 4384 | Data.E_Id := Empty; |
23adb371 | 4385 | end if; |
f9ad6b62 | 4386 | |
824e9320 AC |
4387 | -- Generate: |
4388 | -- Raised_Id : Boolean := False; | |
f9ad6b62 | 4389 | |
36b8f95f | 4390 | Append_To (Decls, |
824e9320 | 4391 | Make_Object_Declaration (Loc, |
36b8f95f | 4392 | Defining_Identifier => Data.Raised_Id, |
e4494292 RD |
4393 | Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), |
4394 | Expression => New_Occurrence_Of (Standard_False, Loc))); | |
bbf14e13 AC |
4395 | |
4396 | if Debug_Generated_Code then | |
4397 | Set_Debug_Info_Needed (Data.Raised_Id); | |
4398 | end if; | |
df3e68b1 HK |
4399 | end Build_Object_Declarations; |
4400 | ||
4401 | --------------------------- | |
4402 | -- Build_Raise_Statement -- | |
4403 | --------------------------- | |
4404 | ||
4405 | function Build_Raise_Statement | |
36b8f95f | 4406 | (Data : Finalization_Exception_Data) return Node_Id |
df3e68b1 | 4407 | is |
ddf67a1d | 4408 | Stmt : Node_Id; |
23adb371 | 4409 | Expr : Node_Id; |
df3e68b1 HK |
4410 | |
4411 | begin | |
57d3adcd | 4412 | -- Standard run-time use the specialized routine |
14848f57 | 4413 | -- Raise_From_Controlled_Operation. |
f9ad6b62 | 4414 | |
23adb371 AC |
4415 | if Exception_Extra_Info |
4416 | and then RTE_Available (RE_Raise_From_Controlled_Operation) | |
4417 | then | |
ddf67a1d | 4418 | Stmt := |
36b8f95f | 4419 | Make_Procedure_Call_Statement (Data.Loc, |
833eaa8a | 4420 | Name => |
e4494292 | 4421 | New_Occurrence_Of |
36b8f95f | 4422 | (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), |
ddf67a1d | 4423 | Parameter_Associations => |
e4494292 | 4424 | New_List (New_Occurrence_Of (Data.E_Id, Data.Loc))); |
e4982b64 | 4425 | |
d72e7628 | 4426 | -- Restricted run-time: exception messages are not supported and hence |
14848f57 AC |
4427 | -- Raise_From_Controlled_Operation is not supported. Raise Program_Error |
4428 | -- instead. | |
f553e7bc | 4429 | |
df3e68b1 | 4430 | else |
ddf67a1d | 4431 | Stmt := |
36b8f95f | 4432 | Make_Raise_Program_Error (Data.Loc, |
ddf67a1d | 4433 | Reason => PE_Finalize_Raised_Exception); |
df3e68b1 HK |
4434 | end if; |
4435 | ||
23adb371 | 4436 | -- Generate: |
799d0e05 | 4437 | |
23adb371 AC |
4438 | -- Raised_Id and then not Abort_Id |
4439 | -- <or> | |
4440 | -- Raised_Id | |
4441 | ||
e4494292 | 4442 | Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc); |
23adb371 AC |
4443 | |
4444 | if Present (Data.Abort_Id) then | |
4445 | Expr := Make_And_Then (Data.Loc, | |
4446 | Left_Opnd => Expr, | |
4447 | Right_Opnd => | |
4448 | Make_Op_Not (Data.Loc, | |
e4494292 | 4449 | Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc))); |
23adb371 AC |
4450 | end if; |
4451 | ||
df3e68b1 | 4452 | -- Generate: |
799d0e05 | 4453 | |
ca5af305 | 4454 | -- if Raised_Id and then not Abort_Id then |
ddf67a1d | 4455 | -- Raise_From_Controlled_Operation (E_Id); |
14848f57 AC |
4456 | -- <or> |
4457 | -- raise Program_Error; -- restricted runtime | |
df3e68b1 HK |
4458 | -- end if; |
4459 | ||
4460 | return | |
36b8f95f | 4461 | Make_If_Statement (Data.Loc, |
23adb371 | 4462 | Condition => Expr, |
ddf67a1d | 4463 | Then_Statements => New_List (Stmt)); |
df3e68b1 HK |
4464 | end Build_Raise_Statement; |
4465 | ||
4466 | ----------------------------- | |
4467 | -- Build_Record_Deep_Procs -- | |
4468 | ----------------------------- | |
4469 | ||
4470 | procedure Build_Record_Deep_Procs (Typ : Entity_Id) is | |
4471 | begin | |
4472 | Set_TSS (Typ, | |
cfae2bed AC |
4473 | Make_Deep_Proc |
4474 | (Prim => Initialize_Case, | |
4475 | Typ => Typ, | |
4476 | Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); | |
df3e68b1 | 4477 | |
51245e2d | 4478 | if not Is_Limited_View (Typ) then |
df3e68b1 | 4479 | Set_TSS (Typ, |
cfae2bed AC |
4480 | Make_Deep_Proc |
4481 | (Prim => Adjust_Case, | |
4482 | Typ => Typ, | |
4483 | Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); | |
df3e68b1 HK |
4484 | end if; |
4485 | ||
d2b4b3da AC |
4486 | -- Do not generate Deep_Finalize and Finalize_Address if finalization is |
4487 | -- suppressed since these routine will not be used. | |
df3e68b1 | 4488 | |
d2b4b3da | 4489 | if not Restriction_Active (No_Finalization) then |
df3e68b1 | 4490 | Set_TSS (Typ, |
cfae2bed | 4491 | Make_Deep_Proc |
d2b4b3da | 4492 | (Prim => Finalize_Case, |
cfae2bed | 4493 | Typ => Typ, |
d2b4b3da AC |
4494 | Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); |
4495 | ||
94295b25 | 4496 | -- Create TSS primitive Finalize_Address (unless CodePeer_Mode) |
d2b4b3da | 4497 | |
89b6c83e AC |
4498 | if not CodePeer_Mode then |
4499 | Set_TSS (Typ, | |
4500 | Make_Deep_Proc | |
4501 | (Prim => Address_Case, | |
4502 | Typ => Typ, | |
4503 | Stmts => Make_Deep_Record_Body (Address_Case, Typ))); | |
4504 | end if; | |
df3e68b1 HK |
4505 | end if; |
4506 | end Build_Record_Deep_Procs; | |
4507 | ||
4508 | ------------------- | |
4509 | -- Cleanup_Array -- | |
4510 | ------------------- | |
4511 | ||
4512 | function Cleanup_Array | |
4513 | (N : Node_Id; | |
4514 | Obj : Node_Id; | |
4515 | Typ : Entity_Id) return List_Id | |
4516 | is | |
4517 | Loc : constant Source_Ptr := Sloc (N); | |
4518 | Index_List : constant List_Id := New_List; | |
4519 | ||
4520 | function Free_Component return List_Id; | |
4521 | -- Generate the code to finalize the task or protected subcomponents | |
4522 | -- of a single component of the array. | |
4523 | ||
4524 | function Free_One_Dimension (Dim : Int) return List_Id; | |
4525 | -- Generate a loop over one dimension of the array | |
4526 | ||
4527 | -------------------- | |
4528 | -- Free_Component -- | |
4529 | -------------------- | |
4530 | ||
4531 | function Free_Component return List_Id is | |
4532 | Stmts : List_Id := New_List; | |
4533 | Tsk : Node_Id; | |
4534 | C_Typ : constant Entity_Id := Component_Type (Typ); | |
4535 | ||
4536 | begin | |
4537 | -- Component type is known to contain tasks or protected objects | |
4538 | ||
4539 | Tsk := | |
4540 | Make_Indexed_Component (Loc, | |
4541 | Prefix => Duplicate_Subexpr_No_Checks (Obj), | |
4542 | Expressions => Index_List); | |
4543 | ||
4544 | Set_Etype (Tsk, C_Typ); | |
4545 | ||
4546 | if Is_Task_Type (C_Typ) then | |
4547 | Append_To (Stmts, Cleanup_Task (N, Tsk)); | |
4548 | ||
4549 | elsif Is_Simple_Protected_Type (C_Typ) then | |
4550 | Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); | |
4551 | ||
4552 | elsif Is_Record_Type (C_Typ) then | |
4553 | Stmts := Cleanup_Record (N, Tsk, C_Typ); | |
4554 | ||
4555 | elsif Is_Array_Type (C_Typ) then | |
4556 | Stmts := Cleanup_Array (N, Tsk, C_Typ); | |
4557 | end if; | |
4558 | ||
4559 | return Stmts; | |
4560 | end Free_Component; | |
4561 | ||
4562 | ------------------------ | |
4563 | -- Free_One_Dimension -- | |
4564 | ------------------------ | |
4565 | ||
4566 | function Free_One_Dimension (Dim : Int) return List_Id is | |
4567 | Index : Entity_Id; | |
4568 | ||
4569 | begin | |
4570 | if Dim > Number_Dimensions (Typ) then | |
4571 | return Free_Component; | |
4572 | ||
4573 | -- Here we generate the required loop | |
4574 | ||
4575 | else | |
4576 | Index := Make_Temporary (Loc, 'J'); | |
e4494292 | 4577 | Append (New_Occurrence_Of (Index, Loc), Index_List); |
df3e68b1 HK |
4578 | |
4579 | return New_List ( | |
4580 | Make_Implicit_Loop_Statement (N, | |
cfae2bed | 4581 | Identifier => Empty, |
df3e68b1 HK |
4582 | Iteration_Scheme => |
4583 | Make_Iteration_Scheme (Loc, | |
4584 | Loop_Parameter_Specification => | |
4585 | Make_Loop_Parameter_Specification (Loc, | |
cfae2bed | 4586 | Defining_Identifier => Index, |
df3e68b1 HK |
4587 | Discrete_Subtype_Definition => |
4588 | Make_Attribute_Reference (Loc, | |
cfae2bed | 4589 | Prefix => Duplicate_Subexpr (Obj), |
df3e68b1 | 4590 | Attribute_Name => Name_Range, |
cfae2bed | 4591 | Expressions => New_List ( |
df3e68b1 | 4592 | Make_Integer_Literal (Loc, Dim))))), |
eedc5882 | 4593 | Statements => Free_One_Dimension (Dim + 1))); |
df3e68b1 HK |
4594 | end if; |
4595 | end Free_One_Dimension; | |
4596 | ||
4597 | -- Start of processing for Cleanup_Array | |
4598 | ||
4599 | begin | |
4600 | return Free_One_Dimension (1); | |
4601 | end Cleanup_Array; | |
4602 | ||
4603 | -------------------- | |
4604 | -- Cleanup_Record -- | |
4605 | -------------------- | |
4606 | ||
4607 | function Cleanup_Record | |
4608 | (N : Node_Id; | |
4609 | Obj : Node_Id; | |
4610 | Typ : Entity_Id) return List_Id | |
4611 | is | |
4612 | Loc : constant Source_Ptr := Sloc (N); | |
df3e68b1 HK |
4613 | Stmts : constant List_Id := New_List; |
4614 | U_Typ : constant Entity_Id := Underlying_Type (Typ); | |
4615 | ||
9880061b HK |
4616 | Comp : Entity_Id; |
4617 | Tsk : Node_Id; | |
4618 | ||
df3e68b1 HK |
4619 | begin |
4620 | if Has_Discriminants (U_Typ) | |
4621 | and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration | |
41c79d60 | 4622 | and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition |
df3e68b1 HK |
4623 | and then |
4624 | Present | |
cfae2bed | 4625 | (Variant_Part (Component_List (Type_Definition (Parent (U_Typ))))) |
df3e68b1 | 4626 | then |
cfae2bed AC |
4627 | -- For now, do not attempt to free a component that may appear in a |
4628 | -- variant, and instead issue a warning. Doing this "properly" would | |
4629 | -- require building a case statement and would be quite a mess. Note | |
4630 | -- that the RM only requires that free "work" for the case of a task | |
4631 | -- access value, so already we go way beyond this in that we deal | |
4632 | -- with the array case and non-discriminated record cases. | |
df3e68b1 HK |
4633 | |
4634 | Error_Msg_N | |
685bc70f | 4635 | ("task/protected object in variant record will not be freed??", N); |
df3e68b1 HK |
4636 | return New_List (Make_Null_Statement (Loc)); |
4637 | end if; | |
4638 | ||
9880061b | 4639 | Comp := First_Component (U_Typ); |
df3e68b1 HK |
4640 | while Present (Comp) loop |
4641 | if Has_Task (Etype (Comp)) | |
4642 | or else Has_Simple_Protected_Object (Etype (Comp)) | |
4643 | then | |
4644 | Tsk := | |
4645 | Make_Selected_Component (Loc, | |
4646 | Prefix => Duplicate_Subexpr_No_Checks (Obj), | |
4647 | Selector_Name => New_Occurrence_Of (Comp, Loc)); | |
4648 | Set_Etype (Tsk, Etype (Comp)); | |
4649 | ||
4650 | if Is_Task_Type (Etype (Comp)) then | |
4651 | Append_To (Stmts, Cleanup_Task (N, Tsk)); | |
4652 | ||
4653 | elsif Is_Simple_Protected_Type (Etype (Comp)) then | |
4654 | Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); | |
4655 | ||
4656 | elsif Is_Record_Type (Etype (Comp)) then | |
4657 | ||
9880061b HK |
4658 | -- Recurse, by generating the prefix of the argument to the |
4659 | -- eventual cleanup call. | |
df3e68b1 | 4660 | |
cfae2bed | 4661 | Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); |
df3e68b1 HK |
4662 | |
4663 | elsif Is_Array_Type (Etype (Comp)) then | |
cfae2bed | 4664 | Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); |
df3e68b1 HK |
4665 | end if; |
4666 | end if; | |
4667 | ||
4668 | Next_Component (Comp); | |
4669 | end loop; | |
4670 | ||
4671 | return Stmts; | |
4672 | end Cleanup_Record; | |
4673 | ||
4674 | ------------------------------ | |
4675 | -- Cleanup_Protected_Object -- | |
4676 | ------------------------------ | |
4677 | ||
4678 | function Cleanup_Protected_Object | |
4679 | (N : Node_Id; | |
4680 | Ref : Node_Id) return Node_Id | |
4681 | is | |
4682 | Loc : constant Source_Ptr := Sloc (N); | |
4683 | ||
4684 | begin | |
e4982b64 AC |
4685 | -- For restricted run-time libraries (Ravenscar), tasks are |
4686 | -- non-terminating, and protected objects can only appear at library | |
4687 | -- level, so we do not want finalization of protected objects. | |
4688 | ||
4689 | if Restricted_Profile then | |
4690 | return Empty; | |
4691 | ||
4692 | else | |
4693 | return | |
4694 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 4695 | Name => |
e4494292 | 4696 | New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc), |
2c1b72d7 | 4697 | Parameter_Associations => New_List (Concurrent_Ref (Ref))); |
e4982b64 | 4698 | end if; |
df3e68b1 HK |
4699 | end Cleanup_Protected_Object; |
4700 | ||
4701 | ------------------ | |
4702 | -- Cleanup_Task -- | |
4703 | ------------------ | |
4704 | ||
4705 | function Cleanup_Task | |
4706 | (N : Node_Id; | |
4707 | Ref : Node_Id) return Node_Id | |
4708 | is | |
4709 | Loc : constant Source_Ptr := Sloc (N); | |
2c1b72d7 | 4710 | |
df3e68b1 | 4711 | begin |
e4982b64 | 4712 | -- For restricted run-time libraries (Ravenscar), tasks are |
0c506265 HK |
4713 | -- non-terminating and they can only appear at library level, |
4714 | -- so we do not want finalization of task objects. | |
e4982b64 AC |
4715 | |
4716 | if Restricted_Profile then | |
4717 | return Empty; | |
4718 | ||
4719 | else | |
4720 | return | |
4721 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 4722 | Name => |
e4494292 | 4723 | New_Occurrence_Of (RTE (RE_Free_Task), Loc), |
2c1b72d7 | 4724 | Parameter_Associations => New_List (Concurrent_Ref (Ref))); |
e4982b64 | 4725 | end if; |
df3e68b1 HK |
4726 | end Cleanup_Task; |
4727 | ||
400ad4e9 | 4728 | -------------------------------------- |
86f32857 | 4729 | -- Check_Unnesting_Elaboration_Code -- |
400ad4e9 | 4730 | -------------------------------------- |
86f32857 ES |
4731 | |
4732 | procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is | |
f68289d8 GD |
4733 | Loc : constant Source_Ptr := Sloc (N); |
4734 | Block_Elab_Proc : Entity_Id := Empty; | |
4735 | ||
4736 | procedure Set_Block_Elab_Proc; | |
4737 | -- Create a defining identifier for a procedure that will replace | |
4738 | -- a block with nested subprograms (unless it has already been created, | |
4739 | -- in which case this is a no-op). | |
4740 | ||
4741 | procedure Set_Block_Elab_Proc is | |
4742 | begin | |
4743 | if No (Block_Elab_Proc) then | |
4744 | Block_Elab_Proc := | |
4745 | Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I')); | |
4746 | end if; | |
4747 | end Set_Block_Elab_Proc; | |
4748 | ||
4749 | procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id); | |
4750 | -- Find entities in the elaboration code of a library package body that | |
4751 | -- contain or represent a subprogram body. A body can appear within a | |
4752 | -- block or a loop or can appear by itself if generated for an object | |
4753 | -- declaration that involves controlled actions. The first such entity | |
4754 | -- forces creation of a new procedure entity (via Set_Block_Elab_Proc) | |
4755 | -- that will be used to reset the scopes of all entities that become | |
4756 | -- local to the new elaboration procedure. This is needed for subsequent | |
4757 | -- unnesting actions, which depend on proper setting of the Scope links | |
4758 | -- to determine the nesting level of each subprogram. | |
51f2fc7d | 4759 | |
51f2fc7d ES |
4760 | ----------------------- |
4761 | -- Find_Local_Scope -- | |
4762 | ----------------------- | |
4763 | ||
f68289d8 | 4764 | procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is |
66f84da8 | 4765 | Id : Entity_Id; |
92a68a04 | 4766 | Stat : Node_Id; |
2e188579 | 4767 | Node : Node_Id; |
51f2fc7d ES |
4768 | |
4769 | begin | |
4770 | Stat := First (L); | |
4771 | while Present (Stat) loop | |
4772 | case Nkind (Stat) is | |
4773 | when N_Block_Statement => | |
2e188579 AC |
4774 | if Present (Identifier (Stat)) then |
4775 | Id := Entity (Identifier (Stat)); | |
2401c98f | 4776 | |
2e188579 AC |
4777 | -- The Scope of this block needs to be reset to the new |
4778 | -- procedure if the block contains nested subprograms. | |
66f84da8 | 4779 | |
2e188579 AC |
4780 | if Present (Id) and then Contains_Subprogram (Id) then |
4781 | Set_Block_Elab_Proc; | |
4782 | Set_Scope (Id, Block_Elab_Proc); | |
4783 | end if; | |
51f2fc7d ES |
4784 | end if; |
4785 | ||
4786 | when N_Loop_Statement => | |
66f84da8 | 4787 | Id := Entity (Identifier (Stat)); |
2401c98f | 4788 | |
f68289d8 | 4789 | if Present (Id) and then Contains_Subprogram (Id) then |
66f84da8 | 4790 | if Scope (Id) = Current_Scope then |
f68289d8 GD |
4791 | Set_Block_Elab_Proc; |
4792 | Set_Scope (Id, Block_Elab_Proc); | |
66f84da8 | 4793 | end if; |
51f2fc7d ES |
4794 | end if; |
4795 | ||
f68289d8 GD |
4796 | -- We traverse the loop's statements as well, which may |
4797 | -- include other block (etc.) statements that need to have | |
4798 | -- their Scope set to Block_Elab_Proc. (Is this really the | |
4799 | -- case, or do such nested blocks refer to the loop scope | |
4800 | -- rather than the loop's enclosing scope???.) | |
51f2fc7d | 4801 | |
f68289d8 | 4802 | Reset_Scopes_To_Block_Elab_Proc (Statements (Stat)); |
51f2fc7d | 4803 | |
f68289d8 GD |
4804 | when N_If_Statement => |
4805 | Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat)); | |
f68289d8 | 4806 | Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat)); |
51f2fc7d | 4807 | |
2e188579 AC |
4808 | Node := First (Elsif_Parts (Stat)); |
4809 | while Present (Node) loop | |
4810 | Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node)); | |
4811 | Next (Node); | |
4812 | end loop; | |
51f2fc7d ES |
4813 | |
4814 | when N_Case_Statement => | |
2e188579 AC |
4815 | Node := First (Alternatives (Stat)); |
4816 | while Present (Node) loop | |
4817 | Reset_Scopes_To_Block_Elab_Proc (Statements (Node)); | |
4818 | Next (Node); | |
4819 | end loop; | |
51f2fc7d | 4820 | |
f68289d8 GD |
4821 | -- Reset the Scope of a subprogram occurring at the top level |
4822 | ||
51f2fc7d | 4823 | when N_Subprogram_Body => |
66f84da8 | 4824 | Id := Defining_Entity (Stat); |
2401c98f | 4825 | |
f68289d8 GD |
4826 | Set_Block_Elab_Proc; |
4827 | Set_Scope (Id, Block_Elab_Proc); | |
51f2fc7d ES |
4828 | |
4829 | when others => | |
4830 | null; | |
4831 | end case; | |
92a68a04 | 4832 | |
51f2fc7d ES |
4833 | Next (Stat); |
4834 | end loop; | |
f68289d8 | 4835 | end Reset_Scopes_To_Block_Elab_Proc; |
51f2fc7d | 4836 | |
f2c2cdfb HK |
4837 | -- Local variables |
4838 | ||
66f84da8 | 4839 | H_Seq : constant Node_Id := Handled_Statement_Sequence (N); |
f2c2cdfb HK |
4840 | Elab_Body : Node_Id; |
4841 | Elab_Call : Node_Id; | |
f2c2cdfb HK |
4842 | |
4843 | -- Start of processing for Check_Unnesting_Elaboration_Code | |
4844 | ||
86f32857 | 4845 | begin |
f68289d8 GD |
4846 | if Present (H_Seq) then |
4847 | Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq)); | |
66f84da8 | 4848 | |
f68289d8 | 4849 | -- There may be subprograms declared in the exception handlers |
66f84da8 ES |
4850 | -- of the current body. |
4851 | ||
f68289d8 | 4852 | if Present (Exception_Handlers (H_Seq)) then |
66f84da8 ES |
4853 | declare |
4854 | Handler : Node_Id := First (Exception_Handlers (H_Seq)); | |
4855 | begin | |
4856 | while Present (Handler) loop | |
f68289d8 | 4857 | Reset_Scopes_To_Block_Elab_Proc (Statements (Handler)); |
66f84da8 ES |
4858 | |
4859 | Next (Handler); | |
4860 | end loop; | |
4861 | end; | |
4862 | end if; | |
86f32857 | 4863 | |
f68289d8 | 4864 | if Present (Block_Elab_Proc) then |
0c506265 HK |
4865 | Elab_Body := |
4866 | Make_Subprogram_Body (Loc, | |
4867 | Specification => | |
4868 | Make_Procedure_Specification (Loc, | |
f68289d8 | 4869 | Defining_Unit_Name => Block_Elab_Proc), |
0c506265 HK |
4870 | Declarations => New_List, |
4871 | Handled_Statement_Sequence => | |
4872 | Relocate_Node (Handled_Statement_Sequence (N))); | |
4873 | ||
4874 | Elab_Call := | |
4875 | Make_Procedure_Call_Statement (Loc, | |
f68289d8 | 4876 | Name => New_Occurrence_Of (Block_Elab_Proc, Loc)); |
86f32857 | 4877 | |
86f32857 ES |
4878 | Append_To (Declarations (N), Elab_Body); |
4879 | Analyze (Elab_Body); | |
f68289d8 | 4880 | Set_Has_Nested_Subprogram (Block_Elab_Proc); |
86f32857 ES |
4881 | |
4882 | Set_Handled_Statement_Sequence (N, | |
0c506265 HK |
4883 | Make_Handled_Sequence_Of_Statements (Loc, |
4884 | Statements => New_List (Elab_Call))); | |
4885 | ||
86f32857 ES |
4886 | Analyze (Elab_Call); |
4887 | ||
f68289d8 GD |
4888 | -- Could we reset the scopes of entities associated with the new |
4889 | -- procedure here via a loop over entities rather than doing it in | |
4890 | -- the recursive Reset_Scopes_To_Elab_Proc procedure??? | |
86f32857 ES |
4891 | end if; |
4892 | end if; | |
4893 | end Check_Unnesting_Elaboration_Code; | |
4894 | ||
f68289d8 GD |
4895 | --------------------------------------- |
4896 | -- Check_Unnesting_In_Decls_Or_Stmts -- | |
4897 | --------------------------------------- | |
302319e0 | 4898 | |
f68289d8 GD |
4899 | procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is |
4900 | Decl_Or_Stmt : Node_Id; | |
302319e0 ES |
4901 | |
4902 | begin | |
302319e0 | 4903 | if Unnest_Subprogram_Mode |
f68289d8 | 4904 | and then Present (Decls_Or_Stmts) |
302319e0 | 4905 | then |
f68289d8 GD |
4906 | Decl_Or_Stmt := First (Decls_Or_Stmts); |
4907 | while Present (Decl_Or_Stmt) loop | |
4908 | if Nkind (Decl_Or_Stmt) = N_Block_Statement | |
4909 | and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt))) | |
e60c10b3 | 4910 | then |
f68289d8 | 4911 | Unnest_Block (Decl_Or_Stmt); |
e60c10b3 | 4912 | |
05746958 GD |
4913 | -- If-statements may contain subprogram bodies at the outer level |
4914 | -- of their statement lists, and the subprograms may make up-level | |
4915 | -- references (such as to objects declared in the same statement | |
4916 | -- list). Unlike block and loop cases, however, we don't have an | |
4917 | -- entity on which to test the Contains_Subprogram flag, so | |
4918 | -- Unnest_If_Statement must traverse the statement lists to | |
4919 | -- determine whether there are nested subprograms present. | |
4920 | ||
4921 | elsif Nkind (Decl_Or_Stmt) = N_If_Statement then | |
4922 | Unnest_If_Statement (Decl_Or_Stmt); | |
4923 | ||
7e536bfd GD |
4924 | elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then |
4925 | declare | |
4926 | Id : constant Entity_Id := | |
4927 | Entity (Identifier (Decl_Or_Stmt)); | |
4928 | ||
4929 | begin | |
4930 | -- When a top-level loop within declarations of a library | |
4931 | -- package spec or body contains nested subprograms, we wrap | |
4932 | -- it in a procedure to handle possible up-level references | |
4933 | -- to entities associated with the loop (such as loop | |
4934 | -- parameters). | |
4935 | ||
4936 | if Present (Id) and then Contains_Subprogram (Id) then | |
4937 | Unnest_Loop (Decl_Or_Stmt); | |
4938 | end if; | |
4939 | end; | |
4940 | ||
f68289d8 GD |
4941 | elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration |
4942 | and then not Modify_Tree_For_C | |
4943 | then | |
4944 | Check_Unnesting_In_Decls_Or_Stmts | |
4945 | (Visible_Declarations (Specification (Decl_Or_Stmt))); | |
4946 | Check_Unnesting_In_Decls_Or_Stmts | |
4947 | (Private_Declarations (Specification (Decl_Or_Stmt))); | |
302319e0 | 4948 | |
f68289d8 GD |
4949 | elsif Nkind (Decl_Or_Stmt) = N_Package_Body |
4950 | and then not Modify_Tree_For_C | |
4951 | then | |
4952 | Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt)); | |
4953 | if Present (Statements | |
4954 | (Handled_Statement_Sequence (Decl_Or_Stmt))) | |
4955 | then | |
4956 | Check_Unnesting_In_Decls_Or_Stmts (Statements | |
4957 | (Handled_Statement_Sequence (Decl_Or_Stmt))); | |
4958 | Check_Unnesting_In_Handlers (Decl_Or_Stmt); | |
4959 | end if; | |
302319e0 ES |
4960 | end if; |
4961 | ||
f68289d8 | 4962 | Next (Decl_Or_Stmt); |
302319e0 ES |
4963 | end loop; |
4964 | end if; | |
f68289d8 GD |
4965 | end Check_Unnesting_In_Decls_Or_Stmts; |
4966 | ||
4967 | --------------------------------- | |
4968 | -- Check_Unnesting_In_Handlers -- | |
4969 | --------------------------------- | |
4970 | ||
4971 | procedure Check_Unnesting_In_Handlers (N : Node_Id) is | |
4972 | Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N); | |
4973 | ||
4974 | begin | |
4975 | if Present (Stmt_Seq) | |
4976 | and then Present (Exception_Handlers (Stmt_Seq)) | |
4977 | then | |
4978 | declare | |
4979 | Handler : Node_Id := First (Exception_Handlers (Stmt_Seq)); | |
4980 | begin | |
4981 | while Present (Handler) loop | |
4982 | if Present (Statements (Handler)) then | |
4983 | Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler)); | |
4984 | end if; | |
4985 | ||
4986 | Next (Handler); | |
4987 | end loop; | |
4988 | end; | |
4989 | end if; | |
4990 | end Check_Unnesting_In_Handlers; | |
302319e0 | 4991 | |
df3e68b1 HK |
4992 | ------------------------------ |
4993 | -- Check_Visibly_Controlled -- | |
4994 | ------------------------------ | |
4995 | ||
4996 | procedure Check_Visibly_Controlled | |
4997 | (Prim : Final_Primitives; | |
4998 | Typ : Entity_Id; | |
4999 | E : in out Entity_Id; | |
5000 | Cref : in out Node_Id) | |
5001 | is | |
5002 | Parent_Type : Entity_Id; | |
5003 | Op : Entity_Id; | |
5004 | ||
5005 | begin | |
5006 | if Is_Derived_Type (Typ) | |
5007 | and then Comes_From_Source (E) | |
5008 | and then not Present (Overridden_Operation (E)) | |
5009 | then | |
5010 | -- We know that the explicit operation on the type does not override | |
5011 | -- the inherited operation of the parent, and that the derivation | |
5012 | -- is from a private type that is not visibly controlled. | |
5013 | ||
5014 | Parent_Type := Etype (Typ); | |
ca811241 | 5015 | Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim)); |
df3e68b1 HK |
5016 | |
5017 | if Present (Op) then | |
5018 | E := Op; | |
5019 | ||
5020 | -- Wrap the object to be initialized into the proper | |
5021 | -- unchecked conversion, to be compatible with the operation | |
5022 | -- to be called. | |
5023 | ||
5024 | if Nkind (Cref) = N_Unchecked_Type_Conversion then | |
5025 | Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); | |
5026 | else | |
5027 | Cref := Unchecked_Convert_To (Parent_Type, Cref); | |
5028 | end if; | |
5029 | end if; | |
5030 | end if; | |
5031 | end Check_Visibly_Controlled; | |
5032 | ||
e60c10b3 ES |
5033 | -------------------------- |
5034 | -- Contains_Subprogram -- | |
5035 | -------------------------- | |
5036 | ||
5037 | function Contains_Subprogram (Blk : Entity_Id) return Boolean is | |
5038 | E : Entity_Id; | |
5039 | ||
5040 | begin | |
5041 | E := First_Entity (Blk); | |
5042 | ||
5043 | while Present (E) loop | |
5044 | if Is_Subprogram (E) then | |
5045 | return True; | |
5046 | ||
4a08c95c | 5047 | elsif Ekind (E) in E_Block | E_Loop |
e60c10b3 ES |
5048 | and then Contains_Subprogram (E) |
5049 | then | |
5050 | return True; | |
5051 | end if; | |
5052 | ||
5053 | Next_Entity (E); | |
5054 | end loop; | |
5055 | ||
5056 | return False; | |
5057 | end Contains_Subprogram; | |
5058 | ||
df3e68b1 HK |
5059 | ------------------ |
5060 | -- Convert_View -- | |
5061 | ------------------ | |
5062 | ||
5063 | function Convert_View | |
5064 | (Proc : Entity_Id; | |
5065 | Arg : Node_Id; | |
5066 | Ind : Pos := 1) return Node_Id | |
5067 | is | |
5068 | Fent : Entity_Id := First_Entity (Proc); | |
5069 | Ftyp : Entity_Id; | |
5070 | Atyp : Entity_Id; | |
5071 | ||
5072 | begin | |
5073 | for J in 2 .. Ind loop | |
5074 | Next_Entity (Fent); | |
5075 | end loop; | |
5076 | ||
5077 | Ftyp := Etype (Fent); | |
5078 | ||
4a08c95c | 5079 | if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then |
df3e68b1 HK |
5080 | Atyp := Entity (Subtype_Mark (Arg)); |
5081 | else | |
5082 | Atyp := Etype (Arg); | |
5083 | end if; | |
5084 | ||
5085 | if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then | |
5086 | return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); | |
5087 | ||
5088 | elsif Ftyp /= Atyp | |
5089 | and then Present (Atyp) | |
cfae2bed AC |
5090 | and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) |
5091 | and then Base_Type (Underlying_Type (Atyp)) = | |
5092 | Base_Type (Underlying_Type (Ftyp)) | |
df3e68b1 HK |
5093 | then |
5094 | return Unchecked_Convert_To (Ftyp, Arg); | |
5095 | ||
5096 | -- If the argument is already a conversion, as generated by | |
5097 | -- Make_Init_Call, set the target type to the type of the formal | |
5098 | -- directly, to avoid spurious typing problems. | |
5099 | ||
4a08c95c | 5100 | elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion |
df3e68b1 HK |
5101 | and then not Is_Class_Wide_Type (Atyp) |
5102 | then | |
5103 | Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); | |
5104 | Set_Etype (Arg, Ftyp); | |
5105 | return Arg; | |
5106 | ||
3c756b76 AC |
5107 | -- Otherwise, introduce a conversion when the designated object |
5108 | -- has a type derived from the formal of the controlled routine. | |
5109 | ||
5110 | elsif Is_Private_Type (Ftyp) | |
5111 | and then Present (Atyp) | |
5112 | and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp))) | |
5113 | then | |
5114 | return Unchecked_Convert_To (Ftyp, Arg); | |
5115 | ||
df3e68b1 HK |
5116 | else |
5117 | return Arg; | |
5118 | end if; | |
5119 | end Convert_View; | |
5120 | ||
32b794c8 AC |
5121 | ------------------------------- |
5122 | -- CW_Or_Has_Controlled_Part -- | |
5123 | ------------------------------- | |
5124 | ||
5125 | function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is | |
5126 | begin | |
5127 | return Is_Class_Wide_Type (T) or else Needs_Finalization (T); | |
5128 | end CW_Or_Has_Controlled_Part; | |
5129 | ||
df3e68b1 HK |
5130 | ------------------------ |
5131 | -- Enclosing_Function -- | |
5132 | ------------------------ | |
5133 | ||
5134 | function Enclosing_Function (E : Entity_Id) return Entity_Id is | |
2c1b72d7 | 5135 | Func_Id : Entity_Id; |
df3e68b1 HK |
5136 | |
5137 | begin | |
2c1b72d7 | 5138 | Func_Id := E; |
36295779 | 5139 | while Present (Func_Id) and then Func_Id /= Standard_Standard loop |
df3e68b1 HK |
5140 | if Ekind (Func_Id) = E_Function then |
5141 | return Func_Id; | |
5142 | end if; | |
5143 | ||
5144 | Func_Id := Scope (Func_Id); | |
5145 | end loop; | |
5146 | ||
5147 | return Empty; | |
5148 | end Enclosing_Function; | |
5149 | ||
5150 | ------------------------------- | |
5151 | -- Establish_Transient_Scope -- | |
5152 | ------------------------------- | |
5153 | ||
5154 | -- This procedure is called each time a transient block has to be inserted | |
5155 | -- that is to say for each call to a function with unconstrained or tagged | |
d4dfb005 | 5156 | -- result. It creates a new scope on the scope stack in order to enclose |
8fdafe44 | 5157 | -- all transient variables generated. |
df3e68b1 | 5158 | |
6560f851 HK |
5159 | procedure Establish_Transient_Scope |
5160 | (N : Node_Id; | |
5161 | Manage_Sec_Stack : Boolean) | |
5162 | is | |
5163 | procedure Create_Transient_Scope (Constr : Node_Id); | |
5164 | -- Place a new scope on the scope stack in order to service construct | |
5165 | -- Constr. The new scope may also manage the secondary stack. | |
df3e68b1 | 5166 | |
6560f851 HK |
5167 | procedure Delegate_Sec_Stack_Management; |
5168 | -- Move the management of the secondary stack to the nearest enclosing | |
5169 | -- suitable scope. | |
df3e68b1 | 5170 | |
6560f851 HK |
5171 | function Find_Enclosing_Transient_Scope return Entity_Id; |
5172 | -- Examine the scope stack looking for the nearest enclosing transient | |
5173 | -- scope. Return Empty if no such scope exists. | |
df3e68b1 | 5174 | |
6560f851 HK |
5175 | function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean; |
5176 | -- Determine whether arbitrary Id denotes a package or subprogram [body] | |
df3e68b1 | 5177 | |
6560f851 HK |
5178 | ---------------------------- |
5179 | -- Create_Transient_Scope -- | |
5180 | ---------------------------- | |
df3e68b1 | 5181 | |
6560f851 HK |
5182 | procedure Create_Transient_Scope (Constr : Node_Id) is |
5183 | Loc : constant Source_Ptr := Sloc (N); | |
df3e68b1 | 5184 | |
6560f851 HK |
5185 | Iter_Loop : Entity_Id; |
5186 | Trans_Scop : Entity_Id; | |
406935b6 | 5187 | |
6560f851 HK |
5188 | begin |
5189 | Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); | |
5190 | Set_Etype (Trans_Scop, Standard_Void_Type); | |
7edfb4c6 | 5191 | |
6560f851 HK |
5192 | Push_Scope (Trans_Scop); |
5193 | Set_Node_To_Be_Wrapped (Constr); | |
df3e68b1 HK |
5194 | Set_Scope_Is_Transient; |
5195 | ||
6560f851 | 5196 | -- The transient scope must also manage the secondary stack |
7edfb4c6 | 5197 | |
6560f851 HK |
5198 | if Manage_Sec_Stack then |
5199 | Set_Uses_Sec_Stack (Trans_Scop); | |
df3e68b1 | 5200 | Check_Restriction (No_Secondary_Stack, N); |
7edfb4c6 HK |
5201 | |
5202 | -- The expansion of iterator loops generates references to objects | |
5203 | -- in order to extract elements from a container: | |
5204 | ||
5205 | -- Ref : Reference_Type_Ptr := Reference (Container, Cursor); | |
5206 | -- Obj : <object type> renames Ref.all.Element.all; | |
5207 | ||
5208 | -- These references are controlled and returned on the secondary | |
5209 | -- stack. A new reference is created at each iteration of the loop | |
5210 | -- and as a result it must be finalized and the space occupied by | |
5211 | -- it on the secondary stack reclaimed at the end of the current | |
5212 | -- iteration. | |
5213 | ||
5214 | -- When the context that requires a transient scope is a call to | |
5215 | -- routine Reference, the node to be wrapped is the source object: | |
5216 | ||
5217 | -- for Obj of Container loop | |
5218 | ||
2a5ec8e6 BD |
5219 | -- Routine Wrap_Transient_Declaration however does not generate |
5220 | -- a physical block as wrapping a declaration will kill it too | |
5221 | -- early. To handle this peculiar case, mark the related iterator | |
5222 | -- loop as requiring the secondary stack. This signals the | |
5223 | -- finalization machinery to manage the secondary stack (see | |
5224 | -- routine Process_Statements_For_Controlled_Objects). | |
7edfb4c6 | 5225 | |
6560f851 | 5226 | Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop); |
7edfb4c6 HK |
5227 | |
5228 | if Present (Iter_Loop) then | |
5229 | Set_Uses_Sec_Stack (Iter_Loop); | |
5230 | end if; | |
df3e68b1 HK |
5231 | end if; |
5232 | ||
df3e68b1 HK |
5233 | if Debug_Flag_W then |
5234 | Write_Str (" <Transient>"); | |
5235 | Write_Eol; | |
5236 | end if; | |
6560f851 HK |
5237 | end Create_Transient_Scope; |
5238 | ||
5239 | ----------------------------------- | |
5240 | -- Delegate_Sec_Stack_Management -- | |
5241 | ----------------------------------- | |
5242 | ||
5243 | procedure Delegate_Sec_Stack_Management is | |
5244 | Scop_Id : Entity_Id; | |
5245 | Scop_Rec : Scope_Stack_Entry; | |
5246 | ||
5247 | begin | |
5248 | for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop | |
5249 | Scop_Rec := Scope_Stack.Table (Index); | |
5250 | Scop_Id := Scop_Rec.Entity; | |
5251 | ||
5252 | -- Prevent the search from going too far or within the scope space | |
5253 | -- of another unit. | |
5254 | ||
5255 | if Scop_Id = Standard_Standard then | |
5256 | return; | |
5257 | ||
5258 | -- No transient scope should be encountered during the traversal | |
5259 | -- because Establish_Transient_Scope should have already handled | |
5260 | -- this case. | |
5261 | ||
5262 | elsif Scop_Rec.Is_Transient then | |
5263 | pragma Assert (False); | |
5264 | return; | |
5265 | ||
5266 | -- The construct which requires secondary stack management is | |
5267 | -- always enclosed by a package or subprogram scope. | |
5268 | ||
5269 | elsif Is_Package_Or_Subprogram (Scop_Id) then | |
5270 | Set_Uses_Sec_Stack (Scop_Id); | |
5271 | Check_Restriction (No_Secondary_Stack, N); | |
5272 | ||
5273 | return; | |
5274 | end if; | |
5275 | end loop; | |
5276 | ||
5277 | -- At this point no suitable scope was found. This should never occur | |
5278 | -- because a construct is always enclosed by a compilation unit which | |
5279 | -- has a scope. | |
5280 | ||
5281 | pragma Assert (False); | |
5282 | end Delegate_Sec_Stack_Management; | |
5283 | ||
5284 | ------------------------------------ | |
5285 | -- Find_Enclosing_Transient_Scope -- | |
5286 | ------------------------------------ | |
5287 | ||
5288 | function Find_Enclosing_Transient_Scope return Entity_Id is | |
5289 | Scop_Id : Entity_Id; | |
5290 | Scop_Rec : Scope_Stack_Entry; | |
5291 | ||
5292 | begin | |
5293 | for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop | |
5294 | Scop_Rec := Scope_Stack.Table (Index); | |
5295 | Scop_Id := Scop_Rec.Entity; | |
5296 | ||
5297 | -- Prevent the search from going too far or within the scope space | |
5298 | -- of another unit. | |
5299 | ||
5300 | if Scop_Id = Standard_Standard | |
5301 | or else Is_Package_Or_Subprogram (Scop_Id) | |
5302 | then | |
5303 | exit; | |
5304 | ||
5305 | elsif Scop_Rec.Is_Transient then | |
5306 | return Scop_Id; | |
5307 | end if; | |
5308 | end loop; | |
5309 | ||
5310 | return Empty; | |
5311 | end Find_Enclosing_Transient_Scope; | |
5312 | ||
6560f851 HK |
5313 | ------------------------------ |
5314 | -- Is_Package_Or_Subprogram -- | |
5315 | ------------------------------ | |
5316 | ||
5317 | function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is | |
5318 | begin | |
4a08c95c AC |
5319 | return Ekind (Id) in E_Entry |
5320 | | E_Entry_Family | |
5321 | | E_Function | |
5322 | | E_Package | |
5323 | | E_Procedure | |
5324 | | E_Subprogram_Body; | |
6560f851 HK |
5325 | end Is_Package_Or_Subprogram; |
5326 | ||
5327 | -- Local variables | |
5328 | ||
66c0fa2c HK |
5329 | Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; |
5330 | Context : Node_Id; | |
6560f851 HK |
5331 | |
5332 | -- Start of processing for Establish_Transient_Scope | |
5333 | ||
5334 | begin | |
5335 | -- Do not create a new transient scope if there is an existing transient | |
5336 | -- scope on the stack. | |
5337 | ||
66c0fa2c | 5338 | if Present (Trans_Id) then |
6560f851 HK |
5339 | |
5340 | -- If the transient scope was requested for purposes of managing the | |
5341 | -- secondary stack, then the existing scope must perform this task. | |
5342 | ||
5343 | if Manage_Sec_Stack then | |
66c0fa2c | 5344 | Set_Uses_Sec_Stack (Trans_Id); |
6560f851 HK |
5345 | end if; |
5346 | ||
5347 | return; | |
5348 | end if; | |
5349 | ||
5350 | -- At this point it is known that the scope stack is free of transient | |
5351 | -- scopes. Locate the proper construct which must be serviced by a new | |
5352 | -- transient scope. | |
5353 | ||
66c0fa2c HK |
5354 | Context := Find_Transient_Context (N); |
5355 | ||
5356 | if Present (Context) then | |
5357 | if Nkind (Context) = N_Assignment_Statement then | |
6560f851 | 5358 | |
66c0fa2c HK |
5359 | -- An assignment statement with suppressed controlled semantics |
5360 | -- does not need a transient scope because finalization is not | |
5361 | -- desirable at this point. Note that No_Ctrl_Actions is also | |
5362 | -- set for non-controlled assignments to suppress dispatching | |
5363 | -- _assign. | |
6560f851 | 5364 | |
66c0fa2c HK |
5365 | if No_Ctrl_Actions (Context) |
5366 | and then Needs_Finalization (Etype (Name (Context))) | |
5367 | then | |
5368 | -- When a controlled component is initialized by a function | |
5369 | -- call, the result on the secondary stack is always assigned | |
5370 | -- to the component. Signal the nearest suitable scope that it | |
5371 | -- is safe to manage the secondary stack. | |
6560f851 | 5372 | |
66c0fa2c HK |
5373 | if Manage_Sec_Stack and then Within_Init_Proc then |
5374 | Delegate_Sec_Stack_Management; | |
5375 | end if; | |
5376 | ||
5377 | -- Otherwise the assignment is a normal transient context and thus | |
5378 | -- requires a transient scope. | |
5379 | ||
5380 | else | |
5381 | Create_Transient_Scope (Context); | |
5382 | end if; | |
5383 | ||
5384 | -- General case | |
5385 | ||
5386 | else | |
5387 | Create_Transient_Scope (Context); | |
5388 | end if; | |
df3e68b1 HK |
5389 | end if; |
5390 | end Establish_Transient_Scope; | |
5391 | ||
5392 | ---------------------------- | |
5393 | -- Expand_Cleanup_Actions -- | |
5394 | ---------------------------- | |
5395 | ||
5396 | procedure Expand_Cleanup_Actions (N : Node_Id) is | |
4a08c95c AC |
5397 | pragma Assert |
5398 | (Nkind (N) in N_Block_Statement | |
5399 | | N_Entry_Body | |
5400 | | N_Extended_Return_Statement | |
5401 | | N_Subprogram_Body | |
5402 | | N_Task_Body); | |
40c21e91 | 5403 | |
df3e68b1 HK |
5404 | Scop : constant Entity_Id := Current_Scope; |
5405 | ||
85be939e AC |
5406 | Is_Asynchronous_Call : constant Boolean := |
5407 | Nkind (N) = N_Block_Statement | |
5408 | and then Is_Asynchronous_Call_Block (N); | |
5409 | Is_Master : constant Boolean := | |
40c21e91 PMR |
5410 | Nkind (N) /= N_Extended_Return_Statement |
5411 | and then Nkind (N) /= N_Entry_Body | |
85be939e AC |
5412 | and then Is_Task_Master (N); |
5413 | Is_Protected_Subp_Body : constant Boolean := | |
5414 | Nkind (N) = N_Subprogram_Body | |
5415 | and then Is_Protected_Subprogram_Body (N); | |
5416 | Is_Task_Allocation : constant Boolean := | |
5417 | Nkind (N) = N_Block_Statement | |
5418 | and then Is_Task_Allocation_Block (N); | |
5419 | Is_Task_Body : constant Boolean := | |
5420 | Nkind (Original_Node (N)) = N_Task_Body; | |
9a975bfc BD |
5421 | |
5422 | -- We mark the secondary stack if it is used in this construct, and | |
5423 | -- we're not returning a function result on the secondary stack, except | |
5424 | -- that a build-in-place function that might or might not return on the | |
5425 | -- secondary stack always needs a mark. A run-time test is required in | |
5426 | -- the case where the build-in-place function has a BIP_Alloc extra | |
5427 | -- parameter (see Create_Finalizer). | |
5428 | ||
85be939e | 5429 | Needs_Sec_Stack_Mark : constant Boolean := |
9a975bfc BD |
5430 | (Uses_Sec_Stack (Scop) |
5431 | and then | |
5432 | not Sec_Stack_Needed_For_Return (Scop)) | |
5433 | or else | |
5434 | (Is_Build_In_Place_Function (Scop) | |
5435 | and then Needs_BIP_Alloc_Form (Scop)); | |
5436 | ||
85be939e AC |
5437 | Needs_Custom_Cleanup : constant Boolean := |
5438 | Nkind (N) = N_Block_Statement | |
5439 | and then Present (Cleanup_Actions (N)); | |
5440 | ||
a1023434 JS |
5441 | Has_Postcondition : constant Boolean := |
5442 | Nkind (N) = N_Subprogram_Body | |
5443 | and then Present | |
5444 | (Postconditions_Proc | |
5445 | (Unique_Defining_Entity (N))); | |
5446 | ||
85be939e AC |
5447 | Actions_Required : constant Boolean := |
5448 | Requires_Cleanup_Actions (N, True) | |
5449 | or else Is_Asynchronous_Call | |
5450 | or else Is_Master | |
5451 | or else Is_Protected_Subp_Body | |
5452 | or else Is_Task_Allocation | |
5453 | or else Is_Task_Body | |
5454 | or else Needs_Sec_Stack_Mark | |
5455 | or else Needs_Custom_Cleanup; | |
df3e68b1 HK |
5456 | |
5457 | HSS : Node_Id := Handled_Statement_Sequence (N); | |
5458 | Loc : Source_Ptr; | |
36295779 | 5459 | Cln : List_Id; |
df3e68b1 HK |
5460 | |
5461 | procedure Wrap_HSS_In_Block; | |
5462 | -- Move HSS inside a new block along with the original exception | |
5463 | -- handlers. Make the newly generated block the sole statement of HSS. | |
5464 | ||
5465 | ----------------------- | |
5466 | -- Wrap_HSS_In_Block -- | |
5467 | ----------------------- | |
5468 | ||
5469 | procedure Wrap_HSS_In_Block is | |
241ebe89 HK |
5470 | Block : Node_Id; |
5471 | Block_Id : Entity_Id; | |
5472 | End_Lab : Node_Id; | |
df3e68b1 HK |
5473 | |
5474 | begin | |
5475 | -- Preserve end label to provide proper cross-reference information | |
5476 | ||
5477 | End_Lab := End_Label (HSS); | |
5478 | Block := | |
d2d8b2a7 | 5479 | Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); |
df3e68b1 | 5480 | |
241ebe89 HK |
5481 | Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); |
5482 | Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc)); | |
5483 | Set_Etype (Block_Id, Standard_Void_Type); | |
5484 | Set_Block_Node (Block_Id, Identifier (Block)); | |
5485 | ||
e98668b1 AC |
5486 | -- Signal the finalization machinery that this particular block |
5487 | -- contains the original context. | |
5488 | ||
5489 | Set_Is_Finalization_Wrapper (Block); | |
5490 | ||
df3e68b1 HK |
5491 | Set_Handled_Statement_Sequence (N, |
5492 | Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); | |
5493 | HSS := Handled_Statement_Sequence (N); | |
5494 | ||
5495 | Set_First_Real_Statement (HSS, Block); | |
5496 | Set_End_Label (HSS, End_Lab); | |
5497 | ||
5498 | -- Comment needed here, see RH for 1.306 ??? | |
5499 | ||
5500 | if Nkind (N) = N_Subprogram_Body then | |
5501 | Set_Has_Nested_Block_With_Handler (Scop); | |
5502 | end if; | |
5503 | end Wrap_HSS_In_Block; | |
5504 | ||
5505 | -- Start of processing for Expand_Cleanup_Actions | |
5506 | ||
5507 | begin | |
5508 | -- The current construct does not need any form of servicing | |
5509 | ||
5510 | if not Actions_Required then | |
5511 | return; | |
5512 | ||
5513 | -- If the current node is a rewritten task body and the descriptors have | |
5514 | -- not been delayed (due to some nested instantiations), do not generate | |
5515 | -- redundant cleanup actions. | |
5516 | ||
5517 | elsif Is_Task_Body | |
5518 | and then Nkind (N) = N_Subprogram_Body | |
5519 | and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) | |
5520 | then | |
5521 | return; | |
5522 | end if; | |
5523 | ||
40c21e91 | 5524 | -- If an extended return statement contains something like |
c581c520 | 5525 | -- |
40c21e91 | 5526 | -- X := F (...); |
c581c520 | 5527 | -- |
40c21e91 | 5528 | -- where F is a build-in-place function call returning a controlled |
c581c520 PMR |
5529 | -- type, then a temporary object will be implicitly declared as part |
5530 | -- of the statement list, and this will need cleanup. In such cases, | |
5531 | -- we transform: | |
40c21e91 PMR |
5532 | -- |
5533 | -- return Result : T := ... do | |
5534 | -- <statements> -- possibly with handlers | |
5535 | -- end return; | |
5536 | -- | |
5537 | -- into: | |
5538 | -- | |
5539 | -- return Result : T := ... do | |
5540 | -- declare -- no declarations | |
5541 | -- begin | |
5542 | -- <statements> -- possibly with handlers | |
5543 | -- end; -- no handlers | |
5544 | -- end return; | |
5545 | -- | |
5546 | -- So Expand_Cleanup_Actions will end up being called recursively on the | |
5547 | -- block statement. | |
5548 | ||
5549 | if Nkind (N) = N_Extended_Return_Statement then | |
5550 | declare | |
5551 | Block : constant Node_Id := | |
c581c520 PMR |
5552 | Make_Block_Statement (Sloc (N), |
5553 | Declarations => Empty_List, | |
5554 | Handled_Statement_Sequence => | |
5555 | Handled_Statement_Sequence (N)); | |
40c21e91 | 5556 | begin |
c581c520 PMR |
5557 | Set_Handled_Statement_Sequence (N, |
5558 | Make_Handled_Sequence_Of_Statements (Sloc (N), | |
5559 | Statements => New_List (Block))); | |
5560 | ||
40c21e91 PMR |
5561 | Analyze (Block); |
5562 | end; | |
5563 | ||
5564 | -- Analysis of the block did all the work | |
5565 | ||
5566 | return; | |
5567 | end if; | |
5568 | ||
36295779 AC |
5569 | if Needs_Custom_Cleanup then |
5570 | Cln := Cleanup_Actions (N); | |
5571 | else | |
5572 | Cln := No_List; | |
5573 | end if; | |
5574 | ||
df3e68b1 HK |
5575 | declare |
5576 | Decls : List_Id := Declarations (N); | |
5577 | Fin_Id : Entity_Id; | |
5578 | Mark : Entity_Id := Empty; | |
5579 | New_Decls : List_Id; | |
df3e68b1 HK |
5580 | |
5581 | begin | |
56af8688 PMR |
5582 | -- If we are generating expanded code for debugging purposes, use the |
5583 | -- Sloc of the point of insertion for the cleanup code. The Sloc will | |
5584 | -- be updated subsequently to reference the proper line in .dg files. | |
5585 | -- If we are not debugging generated code, use No_Location instead, | |
5586 | -- so that no debug information is generated for the cleanup code. | |
5587 | -- This makes the behavior of the NEXT command in GDB monotonic, and | |
5588 | -- makes the placement of breakpoints more accurate. | |
5589 | ||
5590 | if Debug_Generated_Code then | |
5591 | Loc := Sloc (Scop); | |
5592 | else | |
5593 | Loc := No_Location; | |
5594 | end if; | |
5595 | ||
df3e68b1 HK |
5596 | -- A task activation call has already been built for a task |
5597 | -- allocation block. | |
5598 | ||
5599 | if not Is_Task_Allocation then | |
5600 | Build_Task_Activation_Call (N); | |
5601 | end if; | |
5602 | ||
5603 | if Is_Master then | |
5604 | Establish_Task_Master (N); | |
5605 | end if; | |
5606 | ||
5607 | New_Decls := New_List; | |
5608 | ||
5609 | -- If secondary stack is in use, generate: | |
5610 | -- | |
5611 | -- Mnn : constant Mark_Id := SS_Mark; | |
5612 | ||
df3e68b1 HK |
5613 | if Needs_Sec_Stack_Mark then |
5614 | Mark := Make_Temporary (Loc, 'M'); | |
5615 | ||
8e888920 | 5616 | Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark)); |
df3e68b1 HK |
5617 | Set_Uses_Sec_Stack (Scop, False); |
5618 | end if; | |
5619 | ||
5620 | -- If exception handlers are present, wrap the sequence of statements | |
5621 | -- in a block since it is not possible to have exception handlers and | |
5622 | -- an At_End handler in the same construct. | |
5623 | ||
5624 | if Present (Exception_Handlers (HSS)) then | |
5625 | Wrap_HSS_In_Block; | |
5626 | ||
5627 | -- Ensure that the First_Real_Statement field is set | |
5628 | ||
5629 | elsif No (First_Real_Statement (HSS)) then | |
5630 | Set_First_Real_Statement (HSS, First (Statements (HSS))); | |
5631 | end if; | |
5632 | ||
5633 | -- Do not move the Activation_Chain declaration in the context of | |
5634 | -- task allocation blocks. Task allocation blocks use _chain in their | |
5635 | -- cleanup handlers and gigi complains if it is declared in the | |
5636 | -- sequence of statements of the scope that declares the handler. | |
5637 | ||
5638 | if Is_Task_Allocation then | |
5639 | declare | |
5640 | Chain : constant Entity_Id := Activation_Chain_Entity (N); | |
5641 | Decl : Node_Id; | |
5642 | ||
5643 | begin | |
5644 | Decl := First (Decls); | |
5645 | while Nkind (Decl) /= N_Object_Declaration | |
5646 | or else Defining_Identifier (Decl) /= Chain | |
5647 | loop | |
5648 | Next (Decl); | |
5649 | ||
5650 | -- A task allocation block should always include a _chain | |
5651 | -- declaration. | |
5652 | ||
5653 | pragma Assert (Present (Decl)); | |
5654 | end loop; | |
5655 | ||
5656 | Remove (Decl); | |
5657 | Prepend_To (New_Decls, Decl); | |
5658 | end; | |
5659 | end if; | |
5660 | ||
a1023434 JS |
5661 | -- Move the _postconditions subprogram declaration and its associated |
5662 | -- objects into the declarations section so that it is callable | |
5663 | -- within _postconditions. | |
5664 | ||
5665 | if Has_Postcondition then | |
5666 | declare | |
5667 | Decl : Node_Id; | |
5668 | Prev_Decl : Node_Id; | |
5669 | ||
5670 | begin | |
5671 | Decl := | |
5672 | Prev (Subprogram_Body | |
5673 | (Postconditions_Proc (Current_Subprogram))); | |
5674 | while Present (Decl) loop | |
5675 | Prev_Decl := Prev (Decl); | |
5676 | ||
5677 | Remove (Decl); | |
5678 | Prepend_To (New_Decls, Decl); | |
5679 | ||
5680 | exit when Nkind (Decl) = N_Subprogram_Declaration | |
5681 | and then Chars (Corresponding_Body (Decl)) | |
5682 | = Name_uPostconditions; | |
5683 | ||
5684 | Decl := Prev_Decl; | |
5685 | end loop; | |
5686 | end; | |
5687 | end if; | |
5688 | ||
df3e68b1 HK |
5689 | -- Ensure the presence of a declaration list in order to successfully |
5690 | -- append all original statements to it. | |
5691 | ||
5692 | if No (Decls) then | |
5693 | Set_Declarations (N, New_List); | |
5694 | Decls := Declarations (N); | |
5695 | end if; | |
5696 | ||
5697 | -- Move the declarations into the sequence of statements in order to | |
5698 | -- have them protected by the At_End handler. It may seem weird to | |
5699 | -- put declarations in the sequence of statement but in fact nothing | |
5700 | -- forbids that at the tree level. | |
5701 | ||
5702 | Append_List_To (Decls, Statements (HSS)); | |
5703 | Set_Statements (HSS, Decls); | |
5704 | ||
5705 | -- Reset the Sloc of the handled statement sequence to properly | |
5706 | -- reflect the new initial "statement" in the sequence. | |
5707 | ||
5708 | Set_Sloc (HSS, Sloc (First (Decls))); | |
5709 | ||
5710 | -- The declarations of finalizer spec and auxiliary variables replace | |
5711 | -- the old declarations that have been moved inward. | |
5712 | ||
5713 | Set_Declarations (N, New_Decls); | |
5714 | Analyze_Declarations (New_Decls); | |
5715 | ||
5716 | -- Generate finalization calls for all controlled objects appearing | |
5717 | -- in the statements of N. Add context specific cleanup for various | |
5718 | -- constructs. | |
5719 | ||
5720 | Build_Finalizer | |
5721 | (N => N, | |
36295779 | 5722 | Clean_Stmts => Build_Cleanup_Statements (N, Cln), |
df3e68b1 HK |
5723 | Mark_Id => Mark, |
5724 | Top_Decls => New_Decls, | |
5725 | Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body | |
5726 | or else Is_Master, | |
5727 | Fin_Id => Fin_Id); | |
5728 | ||
5729 | if Present (Fin_Id) then | |
5730 | Build_Finalizer_Call (N, Fin_Id); | |
5731 | end if; | |
df3e68b1 HK |
5732 | end; |
5733 | end Expand_Cleanup_Actions; | |
5734 | ||
5735 | --------------------------- | |
5736 | -- Expand_N_Package_Body -- | |
5737 | --------------------------- | |
5738 | ||
5739 | -- Add call to Activate_Tasks if body is an activator (actual processing | |
5740 | -- is in chapter 9). | |
5741 | ||
5742 | -- Generate subprogram descriptor for elaboration routine | |
5743 | ||
5744 | -- Encode entity names in package body | |
5745 | ||
5746 | procedure Expand_N_Package_Body (N : Node_Id) is | |
1af4455a HK |
5747 | Spec_Id : constant Entity_Id := Corresponding_Spec (N); |
5748 | Fin_Id : Entity_Id; | |
5749 | ||
df3e68b1 HK |
5750 | begin |
5751 | -- This is done only for non-generic packages | |
5752 | ||
1af4455a | 5753 | if Ekind (Spec_Id) = E_Package then |
90e491a7 | 5754 | Push_Scope (Spec_Id); |
df3e68b1 HK |
5755 | |
5756 | -- Build dispatch tables of library level tagged types | |
5757 | ||
f46faa08 | 5758 | if Tagged_Type_Expansion |
1af4455a | 5759 | and then Is_Library_Level_Entity (Spec_Id) |
f46faa08 AC |
5760 | then |
5761 | Build_Static_Dispatch_Tables (N); | |
df3e68b1 HK |
5762 | end if; |
5763 | ||
8b7b6263 GL |
5764 | -- If procedures marked with CUDA_Global have been defined within N, |
5765 | -- we need to register them with the CUDA runtime at program startup. | |
5766 | -- This requires multiple declarations and function calls which need | |
5767 | -- to be appended to N's declarations. | |
5768 | ||
5769 | Build_And_Insert_CUDA_Initialization (N); | |
5770 | ||
df3e68b1 | 5771 | Build_Task_Activation_Call (N); |
9b2451e5 | 5772 | |
90e491a7 PMR |
5773 | -- Verify the run-time semantics of pragma Initial_Condition at the |
5774 | -- end of the body statements. | |
9b2451e5 | 5775 | |
90e491a7 | 5776 | Expand_Pragma_Initial_Condition (Spec_Id, N); |
f68289d8 GD |
5777 | |
5778 | -- If this is a library-level package and unnesting is enabled, | |
5779 | -- check for the presence of blocks with nested subprograms occurring | |
5780 | -- in elaboration code, and generate procedures to encapsulate the | |
5781 | -- blocks in case the nested subprograms make up-level references. | |
5782 | ||
5783 | if Unnest_Subprogram_Mode | |
5784 | and then | |
5785 | Is_Library_Level_Entity (Current_Scope) | |
5786 | then | |
5787 | Check_Unnesting_Elaboration_Code (N); | |
5788 | Check_Unnesting_In_Decls_Or_Stmts (Declarations (N)); | |
5789 | Check_Unnesting_In_Handlers (N); | |
5790 | end if; | |
9b2451e5 | 5791 | |
df3e68b1 HK |
5792 | Pop_Scope; |
5793 | end if; | |
5794 | ||
90e491a7 | 5795 | Set_Elaboration_Flag (N, Spec_Id); |
1af4455a | 5796 | Set_In_Package_Body (Spec_Id, False); |
df3e68b1 HK |
5797 | |
5798 | -- Set to encode entity names in package body before gigi is called | |
5799 | ||
5800 | Qualify_Entity_Names (N); | |
5801 | ||
1af4455a | 5802 | if Ekind (Spec_Id) /= E_Generic_Package then |
df3e68b1 HK |
5803 | Build_Finalizer |
5804 | (N => N, | |
26e7e1a0 | 5805 | Clean_Stmts => No_List, |
df3e68b1 HK |
5806 | Mark_Id => Empty, |
5807 | Top_Decls => No_List, | |
5808 | Defer_Abort => False, | |
5809 | Fin_Id => Fin_Id); | |
5810 | ||
5811 | if Present (Fin_Id) then | |
5812 | declare | |
5813 | Body_Ent : Node_Id := Defining_Unit_Name (N); | |
5814 | ||
5815 | begin | |
5816 | if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then | |
5817 | Body_Ent := Defining_Identifier (Body_Ent); | |
5818 | end if; | |
5819 | ||
5820 | Set_Finalizer (Body_Ent, Fin_Id); | |
5821 | end; | |
5822 | end if; | |
5823 | end if; | |
5824 | end Expand_N_Package_Body; | |
5825 | ||
5826 | ---------------------------------- | |
5827 | -- Expand_N_Package_Declaration -- | |
5828 | ---------------------------------- | |
5829 | ||
5830 | -- Add call to Activate_Tasks if there are tasks declared and the package | |
885c4871 | 5831 | -- has no body. Note that in Ada 83 this may result in premature activation |
df3e68b1 HK |
5832 | -- of some tasks, given that we cannot tell whether a body will eventually |
5833 | -- appear. | |
5834 | ||
5835 | procedure Expand_N_Package_Declaration (N : Node_Id) is | |
2c1b72d7 AC |
5836 | Id : constant Entity_Id := Defining_Entity (N); |
5837 | Spec : constant Node_Id := Specification (N); | |
5838 | Decls : List_Id; | |
5839 | Fin_Id : Entity_Id; | |
5840 | ||
df3e68b1 | 5841 | No_Body : Boolean := False; |
2c1b72d7 AC |
5842 | -- True in the case of a package declaration that is a compilation |
5843 | -- unit and for which no associated body will be compiled in this | |
5844 | -- compilation. | |
df3e68b1 HK |
5845 | |
5846 | begin | |
5847 | -- Case of a package declaration other than a compilation unit | |
5848 | ||
5849 | if Nkind (Parent (N)) /= N_Compilation_Unit then | |
5850 | null; | |
5851 | ||
5852 | -- Case of a compilation unit that does not require a body | |
5853 | ||
5854 | elsif not Body_Required (Parent (N)) | |
5855 | and then not Unit_Requires_Body (Id) | |
5856 | then | |
5857 | No_Body := True; | |
5858 | ||
5859 | -- Special case of generating calling stubs for a remote call interface | |
2c1b72d7 AC |
5860 | -- package: even though the package declaration requires one, the body |
5861 | -- won't be processed in this compilation (so any stubs for RACWs | |
5862 | -- declared in the package must be generated here, along with the spec). | |
df3e68b1 HK |
5863 | |
5864 | elsif Parent (N) = Cunit (Main_Unit) | |
5865 | and then Is_Remote_Call_Interface (Id) | |
5866 | and then Distribution_Stub_Mode = Generate_Caller_Stub_Body | |
5867 | then | |
5868 | No_Body := True; | |
5869 | end if; | |
5870 | ||
d72e7628 | 5871 | -- For a nested instance, delay processing until freeze point |
0d566e01 ES |
5872 | |
5873 | if Has_Delayed_Freeze (Id) | |
d72e7628 | 5874 | and then Nkind (Parent (N)) /= N_Compilation_Unit |
0d566e01 ES |
5875 | then |
5876 | return; | |
5877 | end if; | |
5878 | ||
df3e68b1 HK |
5879 | -- For a package declaration that implies no associated body, generate |
5880 | -- task activation call and RACW supporting bodies now (since we won't | |
5881 | -- have a specific separate compilation unit for that). | |
5882 | ||
5883 | if No_Body then | |
5884 | Push_Scope (Id); | |
5885 | ||
9b2451e5 | 5886 | -- Generate RACW subprogram bodies |
df3e68b1 | 5887 | |
9b2451e5 | 5888 | if Has_RACW (Id) then |
df3e68b1 HK |
5889 | Decls := Private_Declarations (Spec); |
5890 | ||
5891 | if No (Decls) then | |
5892 | Decls := Visible_Declarations (Spec); | |
5893 | end if; | |
5894 | ||
5895 | if No (Decls) then | |
5896 | Decls := New_List; | |
5897 | Set_Visible_Declarations (Spec, Decls); | |
5898 | end if; | |
5899 | ||
5900 | Append_RACW_Bodies (Decls, Id); | |
5901 | Analyze_List (Decls); | |
5902 | end if; | |
5903 | ||
9b2451e5 AC |
5904 | -- Generate task activation call as last step of elaboration |
5905 | ||
df3e68b1 | 5906 | if Present (Activation_Chain_Entity (N)) then |
9b2451e5 AC |
5907 | Build_Task_Activation_Call (N); |
5908 | end if; | |
df3e68b1 | 5909 | |
90e491a7 PMR |
5910 | -- Verify the run-time semantics of pragma Initial_Condition at the |
5911 | -- end of the private declarations when the package lacks a body. | |
df3e68b1 | 5912 | |
90e491a7 | 5913 | Expand_Pragma_Initial_Condition (Id, N); |
df3e68b1 HK |
5914 | |
5915 | Pop_Scope; | |
5916 | end if; | |
5917 | ||
5918 | -- Build dispatch tables of library level tagged types | |
5919 | ||
f46faa08 AC |
5920 | if Tagged_Type_Expansion |
5921 | and then (Is_Compilation_Unit (Id) | |
15d8a51d AC |
5922 | or else (Is_Generic_Instance (Id) |
5923 | and then Is_Library_Level_Entity (Id))) | |
df3e68b1 | 5924 | then |
f46faa08 | 5925 | Build_Static_Dispatch_Tables (N); |
df3e68b1 HK |
5926 | end if; |
5927 | ||
5928 | -- Note: it is not necessary to worry about generating a subprogram | |
5929 | -- descriptor, since the only way to get exception handlers into a | |
5930 | -- package spec is to include instantiations, and that would cause | |
5931 | -- generation of subprogram descriptors to be delayed in any case. | |
5932 | ||
5933 | -- Set to encode entity names in package spec before gigi is called | |
5934 | ||
5935 | Qualify_Entity_Names (N); | |
5936 | ||
5937 | if Ekind (Id) /= E_Generic_Package then | |
5938 | Build_Finalizer | |
5939 | (N => N, | |
26e7e1a0 | 5940 | Clean_Stmts => No_List, |
df3e68b1 HK |
5941 | Mark_Id => Empty, |
5942 | Top_Decls => No_List, | |
5943 | Defer_Abort => False, | |
5944 | Fin_Id => Fin_Id); | |
5945 | ||
5946 | Set_Finalizer (Id, Fin_Id); | |
5947 | end if; | |
68f27c97 | 5948 | |
f68289d8 GD |
5949 | -- If this is a library-level package and unnesting is enabled, |
5950 | -- check for the presence of blocks with nested subprograms occurring | |
5951 | -- in elaboration code, and generate procedures to encapsulate the | |
5952 | -- blocks in case the nested subprograms make up-level references. | |
5953 | ||
5954 | if Unnest_Subprogram_Mode | |
5955 | and then Is_Library_Level_Entity (Current_Scope) | |
5956 | then | |
5957 | Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec)); | |
5958 | Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec)); | |
5959 | end if; | |
df3e68b1 HK |
5960 | end Expand_N_Package_Declaration; |
5961 | ||
66c0fa2c HK |
5962 | ---------------------------- |
5963 | -- Find_Transient_Context -- | |
5964 | ---------------------------- | |
df3e68b1 | 5965 | |
66c0fa2c | 5966 | function Find_Transient_Context (N : Node_Id) return Node_Id is |
6560f851 HK |
5967 | Curr : Node_Id; |
5968 | Prev : Node_Id; | |
df3e68b1 HK |
5969 | |
5970 | begin | |
6560f851 HK |
5971 | Curr := N; |
5972 | Prev := Empty; | |
66c0fa2c | 5973 | while Present (Curr) loop |
6560f851 | 5974 | case Nkind (Curr) is |
df3e68b1 | 5975 | |
6560f851 | 5976 | -- Declarations |
df3e68b1 | 5977 | |
6560f851 HK |
5978 | -- Declarations act as a boundary for a transient scope even if |
5979 | -- they are not wrapped, see Wrap_Transient_Declaration. | |
df3e68b1 | 5980 | |
d8f43ee6 HK |
5981 | when N_Object_Declaration |
5982 | | N_Object_Renaming_Declaration | |
5983 | | N_Subtype_Declaration | |
5984 | => | |
6560f851 HK |
5985 | return Curr; |
5986 | ||
5987 | -- Statements | |
df3e68b1 | 5988 | |
6560f851 HK |
5989 | -- Statements and statement-like constructs act as a boundary for |
5990 | -- a transient scope. | |
df3e68b1 | 5991 | |
d8f43ee6 HK |
5992 | when N_Accept_Alternative |
5993 | | N_Attribute_Definition_Clause | |
5994 | | N_Case_Statement | |
6560f851 | 5995 | | N_Case_Statement_Alternative |
d8f43ee6 HK |
5996 | | N_Code_Statement |
5997 | | N_Delay_Alternative | |
5998 | | N_Delay_Until_Statement | |
5999 | | N_Delay_Relative_Statement | |
6000 | | N_Discriminant_Association | |
6001 | | N_Elsif_Part | |
6002 | | N_Entry_Body_Formal_Part | |
6003 | | N_Exit_Statement | |
6004 | | N_If_Statement | |
3c5d07ab | 6005 | | N_Iteration_Scheme |
d8f43ee6 HK |
6006 | | N_Terminate_Alternative |
6007 | => | |
6560f851 HK |
6008 | pragma Assert (Present (Prev)); |
6009 | return Prev; | |
dcfa065d | 6010 | |
6560f851 | 6011 | when N_Assignment_Statement => |
66c0fa2c | 6012 | return Curr; |
6560f851 HK |
6013 | |
6014 | when N_Entry_Call_Statement | |
6015 | | N_Procedure_Call_Statement | |
6016 | => | |
66c0fa2c HK |
6017 | -- When an entry or procedure call acts as the alternative of a |
6018 | -- conditional or timed entry call, the proper context is that | |
6019 | -- of the alternative. | |
6020 | ||
6560f851 | 6021 | if Nkind (Parent (Curr)) = N_Entry_Call_Alternative |
4a08c95c AC |
6022 | and then Nkind (Parent (Parent (Curr))) in |
6023 | N_Conditional_Entry_Call | N_Timed_Entry_Call | |
6560f851 HK |
6024 | then |
6025 | return Parent (Parent (Curr)); | |
66c0fa2c HK |
6026 | |
6027 | -- General case for entry or procedure calls | |
6028 | ||
6560f851 HK |
6029 | else |
6030 | return Curr; | |
6031 | end if; | |
6032 | ||
66c0fa2c | 6033 | when N_Pragma => |
6560f851 | 6034 | |
66c0fa2c HK |
6035 | -- Pragma Check is not a valid transient context in GNATprove |
6036 | -- mode because the pragma must remain unchanged. | |
6037 | ||
6038 | if GNATprove_Mode | |
6039 | and then Get_Pragma_Id (Curr) = Pragma_Check | |
6040 | then | |
6041 | return Empty; | |
6042 | ||
6043 | -- General case for pragmas | |
6044 | ||
6045 | else | |
6046 | return Curr; | |
6047 | end if; | |
6048 | ||
6049 | when N_Raise_Statement => | |
6050 | return Curr; | |
6560f851 HK |
6051 | |
6052 | when N_Simple_Return_Statement => | |
66c0fa2c HK |
6053 | |
6054 | -- A return statement is not a valid transient context when the | |
6055 | -- function itself requires transient scope management because | |
6056 | -- the result will be reclaimed too early. | |
6057 | ||
6560f851 HK |
6058 | if Requires_Transient_Scope (Etype |
6059 | (Return_Applies_To (Return_Statement_Entity (Curr)))) | |
df3e68b1 | 6060 | then |
6560f851 | 6061 | return Empty; |
66c0fa2c HK |
6062 | |
6063 | -- General case for return statements | |
6064 | ||
6560f851 HK |
6065 | else |
6066 | return Curr; | |
df3e68b1 | 6067 | end if; |
70482933 | 6068 | |
6560f851 | 6069 | -- Special |
70482933 | 6070 | |
6560f851 HK |
6071 | when N_Attribute_Reference => |
6072 | if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then | |
6073 | return Curr; | |
6074 | end if; | |
14532762 | 6075 | |
3c5d07ab HK |
6076 | -- An Ada 2012 iterator specification is not a valid context |
6077 | -- because Analyze_Iterator_Specification already employs special | |
6078 | -- processing for it. | |
66c0fa2c | 6079 | |
3c5d07ab | 6080 | when N_Iterator_Specification => |
66c0fa2c | 6081 | return Empty; |
14532762 | 6082 | |
df3e68b1 | 6083 | when N_Loop_Parameter_Specification => |
66c0fa2c HK |
6084 | |
6085 | -- An iteration scheme is not a valid context because routine | |
6086 | -- Analyze_Iteration_Scheme already employs special processing. | |
6087 | ||
6088 | if Nkind (Parent (Curr)) = N_Iteration_Scheme then | |
6089 | return Empty; | |
6090 | else | |
6091 | return Parent (Curr); | |
6092 | end if; | |
6560f851 HK |
6093 | |
6094 | -- Termination | |
70482933 | 6095 | |
6560f851 HK |
6096 | -- The following nodes represent "dummy contexts" which do not |
6097 | -- need to be wrapped. | |
dfd99a80 | 6098 | |
d8f43ee6 HK |
6099 | when N_Component_Declaration |
6100 | | N_Discriminant_Specification | |
6101 | | N_Parameter_Specification | |
6102 | => | |
df3e68b1 | 6103 | return Empty; |
dfd99a80 | 6104 | |
6560f851 HK |
6105 | -- If the traversal leaves a scope without having been able to |
6106 | -- find a construct to wrap, something is going wrong, but this | |
6107 | -- can happen in error situations that are not detected yet (such | |
6108 | -- as a dynamic string in a pragma Export). | |
70482933 | 6109 | |
d8f43ee6 | 6110 | when N_Block_Statement |
6560f851 | 6111 | | N_Entry_Body |
d8f43ee6 HK |
6112 | | N_Package_Body |
6113 | | N_Package_Declaration | |
6560f851 | 6114 | | N_Protected_Body |
d8f43ee6 | 6115 | | N_Subprogram_Body |
6560f851 | 6116 | | N_Task_Body |
d8f43ee6 | 6117 | => |
df3e68b1 | 6118 | return Empty; |
70482933 | 6119 | |
6560f851 | 6120 | -- Default |
70482933 | 6121 | |
df3e68b1 HK |
6122 | when others => |
6123 | null; | |
6124 | end case; | |
f65c67d3 | 6125 | |
6560f851 HK |
6126 | Prev := Curr; |
6127 | Curr := Parent (Curr); | |
df3e68b1 | 6128 | end loop; |
66c0fa2c HK |
6129 | |
6130 | return Empty; | |
6131 | end Find_Transient_Context; | |
70482933 | 6132 | |
df3e68b1 HK |
6133 | ---------------------------------- |
6134 | -- Has_New_Controlled_Component -- | |
6135 | ---------------------------------- | |
70482933 | 6136 | |
df3e68b1 HK |
6137 | function Has_New_Controlled_Component (E : Entity_Id) return Boolean is |
6138 | Comp : Entity_Id; | |
70482933 | 6139 | |
df3e68b1 HK |
6140 | begin |
6141 | if not Is_Tagged_Type (E) then | |
6142 | return Has_Controlled_Component (E); | |
6143 | elsif not Is_Derived_Type (E) then | |
6144 | return Has_Controlled_Component (E); | |
70482933 RK |
6145 | end if; |
6146 | ||
df3e68b1 HK |
6147 | Comp := First_Component (E); |
6148 | while Present (Comp) loop | |
df3e68b1 HK |
6149 | if Chars (Comp) = Name_uParent then |
6150 | null; | |
70482933 | 6151 | |
df3e68b1 HK |
6152 | elsif Scope (Original_Record_Component (Comp)) = E |
6153 | and then Needs_Finalization (Etype (Comp)) | |
6154 | then | |
6155 | return True; | |
6156 | end if; | |
70482933 | 6157 | |
df3e68b1 HK |
6158 | Next_Component (Comp); |
6159 | end loop; | |
70482933 | 6160 | |
df3e68b1 HK |
6161 | return False; |
6162 | end Has_New_Controlled_Component; | |
70482933 | 6163 | |
df3e68b1 HK |
6164 | --------------------------------- |
6165 | -- Has_Simple_Protected_Object -- | |
6166 | --------------------------------- | |
70482933 | 6167 | |
df3e68b1 HK |
6168 | function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is |
6169 | begin | |
6170 | if Has_Task (T) then | |
6171 | return False; | |
dcfa065d | 6172 | |
df3e68b1 HK |
6173 | elsif Is_Simple_Protected_Type (T) then |
6174 | return True; | |
dcfa065d | 6175 | |
df3e68b1 HK |
6176 | elsif Is_Array_Type (T) then |
6177 | return Has_Simple_Protected_Object (Component_Type (T)); | |
70482933 | 6178 | |
df3e68b1 HK |
6179 | elsif Is_Record_Type (T) then |
6180 | declare | |
6181 | Comp : Entity_Id; | |
70482933 | 6182 | |
df3e68b1 HK |
6183 | begin |
6184 | Comp := First_Component (T); | |
df3e68b1 HK |
6185 | while Present (Comp) loop |
6186 | if Has_Simple_Protected_Object (Etype (Comp)) then | |
6187 | return True; | |
6188 | end if; | |
70482933 | 6189 | |
df3e68b1 HK |
6190 | Next_Component (Comp); |
6191 | end loop; | |
70482933 | 6192 | |
df3e68b1 HK |
6193 | return False; |
6194 | end; | |
70482933 | 6195 | |
df3e68b1 HK |
6196 | else |
6197 | return False; | |
6198 | end if; | |
6199 | end Has_Simple_Protected_Object; | |
70482933 | 6200 | |
df3e68b1 HK |
6201 | ------------------------------------ |
6202 | -- Insert_Actions_In_Scope_Around -- | |
6203 | ------------------------------------ | |
fbf5a39b | 6204 | |
8e888920 AC |
6205 | procedure Insert_Actions_In_Scope_Around |
6206 | (N : Node_Id; | |
6207 | Clean : Boolean; | |
6208 | Manage_SS : Boolean) | |
6209 | is | |
36295779 AC |
6210 | Act_Before : constant List_Id := |
6211 | Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before); | |
8071b771 AC |
6212 | Act_After : constant List_Id := |
6213 | Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After); | |
6214 | Act_Cleanup : constant List_Id := | |
6215 | Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup); | |
d7f41b2d | 6216 | -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack. |
937e9676 | 6217 | -- Last), but this was incorrect as Process_Transients_In_Scope may |
d7f41b2d | 6218 | -- introduce new scopes and cause a reallocation of Scope_Stack.Table. |
df3e68b1 | 6219 | |
937e9676 | 6220 | procedure Process_Transients_In_Scope |
2c1b72d7 AC |
6221 | (First_Object : Node_Id; |
6222 | Last_Object : Node_Id; | |
6223 | Related_Node : Node_Id); | |
937e9676 AC |
6224 | -- Find all transient objects in the list First_Object .. Last_Object |
6225 | -- and generate finalization actions for them. Related_Node denotes the | |
6226 | -- node which created all transient objects. | |
df3e68b1 | 6227 | |
937e9676 AC |
6228 | --------------------------------- |
6229 | -- Process_Transients_In_Scope -- | |
6230 | --------------------------------- | |
df3e68b1 | 6231 | |
937e9676 | 6232 | procedure Process_Transients_In_Scope |
2c1b72d7 AC |
6233 | (First_Object : Node_Id; |
6234 | Last_Object : Node_Id; | |
6235 | Related_Node : Node_Id) | |
70482933 | 6236 | is |
36eef04a | 6237 | Must_Hook : Boolean := False; |
937e9676 | 6238 | -- Flag denoting whether the context requires transient object |
36eef04a | 6239 | -- export to the outer finalizer. |
8c5b03a0 | 6240 | |
36eef04a AC |
6241 | function Is_Subprogram_Call (N : Node_Id) return Traverse_Result; |
6242 | -- Determine whether an arbitrary node denotes a subprogram call | |
9b168a8b | 6243 | |
97779c34 AC |
6244 | procedure Detect_Subprogram_Call is |
6245 | new Traverse_Proc (Is_Subprogram_Call); | |
6246 | ||
937e9676 AC |
6247 | procedure Process_Transient_In_Scope |
6248 | (Obj_Decl : Node_Id; | |
6249 | Blk_Data : Finalization_Exception_Data; | |
6250 | Blk_Stmts : List_Id); | |
6251 | -- Generate finalization actions for a single transient object | |
6252 | -- denoted by object declaration Obj_Decl. Blk_Data is the | |
6253 | -- exception data of the enclosing block. Blk_Stmts denotes the | |
6254 | -- statements of the enclosing block. | |
6255 | ||
36eef04a AC |
6256 | ------------------------ |
6257 | -- Is_Subprogram_Call -- | |
6258 | ------------------------ | |
6259 | ||
6260 | function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is | |
9b168a8b | 6261 | begin |
18431dc5 AC |
6262 | -- A regular procedure or function call |
6263 | ||
6264 | if Nkind (N) in N_Subprogram_Call then | |
6265 | Must_Hook := True; | |
6266 | return Abandon; | |
6267 | ||
6268 | -- Special cases | |
36eef04a | 6269 | |
18431dc5 AC |
6270 | -- Heavy expansion may relocate function calls outside the related |
6271 | -- node. Inspect the original node to detect the initial placement | |
6272 | -- of the call. | |
6273 | ||
dc67cfea | 6274 | elsif Is_Rewrite_Substitution (N) then |
18431dc5 | 6275 | Detect_Subprogram_Call (Original_Node (N)); |
e2ef0ff6 AC |
6276 | |
6277 | if Must_Hook then | |
6278 | return Abandon; | |
6279 | else | |
6280 | return OK; | |
6281 | end if; | |
6282 | ||
18431dc5 | 6283 | -- Generalized indexing always involves a function call |
36eef04a | 6284 | |
18431dc5 AC |
6285 | elsif Nkind (N) = N_Indexed_Component |
6286 | and then Present (Generalized_Indexing (N)) | |
36eef04a AC |
6287 | then |
6288 | Must_Hook := True; | |
6289 | return Abandon; | |
6290 | ||
6291 | -- Keep searching | |
6292 | ||
6293 | else | |
6294 | return OK; | |
6295 | end if; | |
6296 | end Is_Subprogram_Call; | |
6297 | ||
937e9676 AC |
6298 | -------------------------------- |
6299 | -- Process_Transient_In_Scope -- | |
6300 | -------------------------------- | |
9b168a8b | 6301 | |
937e9676 AC |
6302 | procedure Process_Transient_In_Scope |
6303 | (Obj_Decl : Node_Id; | |
6304 | Blk_Data : Finalization_Exception_Data; | |
6305 | Blk_Stmts : List_Id) | |
6306 | is | |
6307 | Loc : constant Source_Ptr := Sloc (Obj_Decl); | |
6308 | Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); | |
6309 | Fin_Call : Node_Id; | |
6310 | Fin_Stmts : List_Id; | |
6311 | Hook_Assign : Node_Id; | |
6312 | Hook_Clear : Node_Id; | |
6313 | Hook_Decl : Node_Id; | |
6314 | Hook_Insert : Node_Id; | |
6315 | Ptr_Decl : Node_Id; | |
6316 | ||
6317 | begin | |
6318 | -- Mark the transient object as successfully processed to avoid | |
6319 | -- double finalization. | |
6320 | ||
6321 | Set_Is_Finalized_Transient (Obj_Id); | |
6322 | ||
6323 | -- Construct all the pieces necessary to hook and finalize the | |
6324 | -- transient object. | |
6325 | ||
6326 | Build_Transient_Object_Statements | |
6327 | (Obj_Decl => Obj_Decl, | |
6328 | Fin_Call => Fin_Call, | |
6329 | Hook_Assign => Hook_Assign, | |
6330 | Hook_Clear => Hook_Clear, | |
6331 | Hook_Decl => Hook_Decl, | |
6332 | Ptr_Decl => Ptr_Decl); | |
6333 | ||
6334 | -- The context contains at least one subprogram call which may | |
6335 | -- raise an exception. This scenario employs "hooking" to pass | |
6336 | -- transient objects to the enclosing finalizer in case of an | |
6337 | -- exception. | |
6338 | ||
6339 | if Must_Hook then | |
6340 | ||
6341 | -- Add the access type which provides a reference to the | |
6342 | -- transient object. Generate: | |
6343 | ||
6344 | -- type Ptr_Typ is access all Desig_Typ; | |
6345 | ||
6346 | Insert_Action (Obj_Decl, Ptr_Decl); | |
6347 | ||
6348 | -- Add the temporary which acts as a hook to the transient | |
6349 | -- object. Generate: | |
6350 | ||
6351 | -- Hook : Ptr_Typ := null; | |
6352 | ||
6353 | Insert_Action (Obj_Decl, Hook_Decl); | |
6354 | ||
6355 | -- When the transient object is initialized by an aggregate, | |
6356 | -- the hook must capture the object after the last aggregate | |
6357 | -- assignment takes place. Only then is the object considered | |
6358 | -- fully initialized. Generate: | |
6359 | ||
6360 | -- Hook := Ptr_Typ (Obj_Id); | |
6361 | -- <or> | |
6362 | -- Hook := Obj_Id'Unrestricted_Access; | |
6363 | ||
7e8e3cb4 AC |
6364 | -- Similarly if we have a build in place call: we must |
6365 | -- initialize Hook only after the call has happened, otherwise | |
6366 | -- Obj_Id will not be initialized yet. | |
6367 | ||
6368 | if Ekind (Obj_Id) in E_Constant | E_Variable then | |
6369 | if Present (Last_Aggregate_Assignment (Obj_Id)) then | |
6370 | Hook_Insert := Last_Aggregate_Assignment (Obj_Id); | |
6371 | elsif Present (BIP_Initialization_Call (Obj_Id)) then | |
6372 | Hook_Insert := BIP_Initialization_Call (Obj_Id); | |
6373 | else | |
6374 | Hook_Insert := Obj_Decl; | |
6375 | end if; | |
937e9676 AC |
6376 | |
6377 | -- Otherwise the hook seizes the related object immediately | |
6378 | ||
6379 | else | |
6380 | Hook_Insert := Obj_Decl; | |
6381 | end if; | |
6382 | ||
6383 | Insert_After_And_Analyze (Hook_Insert, Hook_Assign); | |
6384 | end if; | |
6385 | ||
6386 | -- When exception propagation is enabled wrap the hook clear | |
6387 | -- statement and the finalization call into a block to catch | |
6388 | -- potential exceptions raised during finalization. Generate: | |
6389 | ||
6390 | -- begin | |
6391 | -- [Hook := null;] | |
6392 | -- [Deep_]Finalize (Obj_Ref); | |
6393 | ||
6394 | -- exception | |
6395 | -- when others => | |
6396 | -- if not Raised then | |
6397 | -- Raised := True; | |
6398 | -- Save_Occurrence | |
6399 | -- (Enn, Get_Current_Excep.all.all); | |
6400 | -- end if; | |
6401 | -- end; | |
6402 | ||
6403 | if Exceptions_OK then | |
6404 | Fin_Stmts := New_List; | |
6405 | ||
6406 | if Must_Hook then | |
6407 | Append_To (Fin_Stmts, Hook_Clear); | |
6408 | end if; | |
6409 | ||
6410 | Append_To (Fin_Stmts, Fin_Call); | |
6411 | ||
6412 | Prepend_To (Blk_Stmts, | |
6413 | Make_Block_Statement (Loc, | |
6414 | Handled_Statement_Sequence => | |
6415 | Make_Handled_Sequence_Of_Statements (Loc, | |
6416 | Statements => Fin_Stmts, | |
6417 | Exception_Handlers => New_List ( | |
6418 | Build_Exception_Handler (Blk_Data))))); | |
6419 | ||
6420 | -- Otherwise generate: | |
6421 | ||
6422 | -- [Hook := null;] | |
6423 | -- [Deep_]Finalize (Obj_Ref); | |
6424 | ||
6425 | -- Note that the statements are inserted in reverse order to | |
6426 | -- achieve the desired final order outlined above. | |
6427 | ||
6428 | else | |
6429 | Prepend_To (Blk_Stmts, Fin_Call); | |
6430 | ||
6431 | if Must_Hook then | |
6432 | Prepend_To (Blk_Stmts, Hook_Clear); | |
6433 | end if; | |
6434 | end if; | |
6435 | end Process_Transient_In_Scope; | |
6436 | ||
6437 | -- Local variables | |
6e840989 | 6438 | |
8c5b03a0 | 6439 | Built : Boolean := False; |
937e9676 | 6440 | Blk_Data : Finalization_Exception_Data; |
6e840989 HK |
6441 | Blk_Decl : Node_Id := Empty; |
6442 | Blk_Decls : List_Id := No_List; | |
6443 | Blk_Ins : Node_Id; | |
a6b13d32 AC |
6444 | Blk_Stmts : List_Id := No_List; |
6445 | Loc : Source_Ptr := No_Location; | |
6e840989 | 6446 | Obj_Decl : Node_Id; |
8c5b03a0 | 6447 | |
937e9676 | 6448 | -- Start of processing for Process_Transients_In_Scope |
3217f71e | 6449 | |
70482933 | 6450 | begin |
6e840989 HK |
6451 | -- The expansion performed by this routine is as follows: |
6452 | ||
6453 | -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; | |
6454 | -- Hook_1 : Ptr_Typ_1 := null; | |
6455 | -- Ctrl_Trans_Obj_1 : ...; | |
6456 | -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; | |
6457 | -- . . . | |
6458 | -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; | |
6459 | -- Hook_N : Ptr_Typ_N := null; | |
6460 | -- Ctrl_Trans_Obj_N : ...; | |
6461 | -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; | |
6462 | ||
6463 | -- declare | |
6464 | -- Abrt : constant Boolean := ...; | |
6465 | -- Ex : Exception_Occurrence; | |
6466 | -- Raised : Boolean := False; | |
6467 | ||
6468 | -- begin | |
7bf911b5 HK |
6469 | -- Abort_Defer; |
6470 | ||
6e840989 HK |
6471 | -- begin |
6472 | -- Hook_N := null; | |
6473 | -- [Deep_]Finalize (Ctrl_Trans_Obj_N); | |
6474 | ||
6475 | -- exception | |
6476 | -- when others => | |
6477 | -- if not Raised then | |
6478 | -- Raised := True; | |
6479 | -- Save_Occurrence (Ex, Get_Current_Excep.all.all); | |
6480 | -- end; | |
6481 | -- . . . | |
6482 | -- begin | |
6483 | -- Hook_1 := null; | |
6484 | -- [Deep_]Finalize (Ctrl_Trans_Obj_1); | |
6485 | ||
6486 | -- exception | |
6487 | -- when others => | |
6488 | -- if not Raised then | |
6489 | -- Raised := True; | |
6490 | -- Save_Occurrence (Ex, Get_Current_Excep.all.all); | |
6491 | -- end; | |
6492 | ||
937e9676 AC |
6493 | -- Abort_Undefer; |
6494 | ||
6e840989 HK |
6495 | -- if Raised and not Abrt then |
6496 | -- Raise_From_Controlled_Operation (Ex); | |
6497 | -- end if; | |
6e840989 HK |
6498 | -- end; |
6499 | ||
8c7ff9a0 AC |
6500 | -- Recognize a scenario where the transient context is an object |
6501 | -- declaration initialized by a build-in-place function call: | |
6502 | ||
6503 | -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call); | |
6504 | ||
6505 | -- The rough expansion of the above is: | |
6506 | ||
6507 | -- Temp : ... := Ctrl_Func_Call; | |
6508 | -- Obj : ...; | |
6509 | -- Res : ... := BIP_Func_Call (..., Obj, ...); | |
6510 | ||
937e9676 AC |
6511 | -- The finalization of any transient object must happen after the |
6512 | -- build-in-place function call is executed. | |
8c7ff9a0 AC |
6513 | |
6514 | if Nkind (N) = N_Object_Declaration | |
6515 | and then Present (BIP_Initialization_Call (Defining_Identifier (N))) | |
6516 | then | |
6517 | Must_Hook := True; | |
6e840989 | 6518 | Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N)); |
8c7ff9a0 | 6519 | |
36eef04a AC |
6520 | -- Search the context for at least one subprogram call. If found, the |
6521 | -- machinery exports all transient objects to the enclosing finalizer | |
6522 | -- due to the possibility of abnormal call termination. | |
6523 | ||
8c7ff9a0 AC |
6524 | else |
6525 | Detect_Subprogram_Call (N); | |
6e840989 HK |
6526 | Blk_Ins := Last_Object; |
6527 | end if; | |
6528 | ||
6529 | if Clean then | |
6530 | Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup); | |
8c7ff9a0 | 6531 | end if; |
36eef04a | 6532 | |
df3e68b1 | 6533 | -- Examine all objects in the list First_Object .. Last_Object |
70482933 | 6534 | |
6e840989 HK |
6535 | Obj_Decl := First_Object; |
6536 | while Present (Obj_Decl) loop | |
6537 | if Nkind (Obj_Decl) = N_Object_Declaration | |
6538 | and then Analyzed (Obj_Decl) | |
6539 | and then Is_Finalizable_Transient (Obj_Decl, N) | |
70482933 | 6540 | |
2c1b72d7 AC |
6541 | -- Do not process the node to be wrapped since it will be |
6542 | -- handled by the enclosing finalizer. | |
70482933 | 6543 | |
6e840989 | 6544 | and then Obj_Decl /= Related_Node |
df3e68b1 | 6545 | then |
937e9676 | 6546 | Loc := Sloc (Obj_Decl); |
8c5b03a0 | 6547 | |
40c21e91 | 6548 | -- Before generating the cleanup code for the first transient |
6e840989 HK |
6549 | -- object, create a wrapper block which houses all hook clear |
6550 | -- statements and finalization calls. This wrapper is needed by | |
40c21e91 | 6551 | -- the back end. |
6e840989 HK |
6552 | |
6553 | if not Built then | |
6554 | Built := True; | |
6555 | Blk_Stmts := New_List; | |
8c5b03a0 | 6556 | |
937e9676 AC |
6557 | -- Generate: |
6558 | -- Abrt : constant Boolean := ...; | |
6559 | -- Ex : Exception_Occurrence; | |
6560 | -- Raised : Boolean := False; | |
8c5b03a0 | 6561 | |
6e840989 HK |
6562 | if Exceptions_OK then |
6563 | Blk_Decls := New_List; | |
937e9676 | 6564 | Build_Object_Declarations (Blk_Data, Blk_Decls, Loc); |
6e840989 HK |
6565 | end if; |
6566 | ||
6567 | Blk_Decl := | |
6568 | Make_Block_Statement (Loc, | |
6569 | Declarations => Blk_Decls, | |
6570 | Handled_Statement_Sequence => | |
6571 | Make_Handled_Sequence_Of_Statements (Loc, | |
6572 | Statements => Blk_Stmts)); | |
8c5b03a0 AC |
6573 | end if; |
6574 | ||
937e9676 AC |
6575 | -- Construct all necessary circuitry to hook and finalize a |
6576 | -- single transient object. | |
8c5b03a0 | 6577 | |
a6b13d32 | 6578 | pragma Assert (Present (Blk_Stmts)); |
937e9676 AC |
6579 | Process_Transient_In_Scope |
6580 | (Obj_Decl => Obj_Decl, | |
6581 | Blk_Data => Blk_Data, | |
6582 | Blk_Stmts => Blk_Stmts); | |
5eeeed5e | 6583 | end if; |
79ee6ab3 | 6584 | |
5eeeed5e AC |
6585 | -- Terminate the scan after the last object has been processed to |
6586 | -- avoid touching unrelated code. | |
fbf5a39b | 6587 | |
6e840989 | 6588 | if Obj_Decl = Last_Object then |
df3e68b1 HK |
6589 | exit; |
6590 | end if; | |
70482933 | 6591 | |
6e840989 | 6592 | Next (Obj_Decl); |
df3e68b1 | 6593 | end loop; |
70482933 | 6594 | |
937e9676 AC |
6595 | -- Complete the decoration of the enclosing finalization block and |
6596 | -- insert it into the tree. | |
6597 | ||
6e840989 | 6598 | if Present (Blk_Decl) then |
7bf911b5 | 6599 | |
a6b13d32 AC |
6600 | pragma Assert (Present (Blk_Stmts)); |
6601 | pragma Assert (Loc /= No_Location); | |
6602 | ||
937e9676 AC |
6603 | -- Note that this Abort_Undefer does not require a extra block or |
6604 | -- an AT_END handler because each finalization exception is caught | |
6605 | -- in its own corresponding finalization block. As a result, the | |
6606 | -- call to Abort_Defer always takes place. | |
7bf911b5 HK |
6607 | |
6608 | if Abort_Allowed then | |
6609 | Prepend_To (Blk_Stmts, | |
6610 | Build_Runtime_Call (Loc, RE_Abort_Defer)); | |
6611 | ||
6612 | Append_To (Blk_Stmts, | |
6613 | Build_Runtime_Call (Loc, RE_Abort_Undefer)); | |
6614 | end if; | |
6615 | ||
937e9676 AC |
6616 | -- Generate: |
6617 | -- if Raised and then not Abrt then | |
6618 | -- Raise_From_Controlled_Operation (Ex); | |
6619 | -- end if; | |
6620 | ||
6621 | if Exceptions_OK then | |
6622 | Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data)); | |
6623 | end if; | |
6624 | ||
6e840989 | 6625 | Insert_After_And_Analyze (Blk_Ins, Blk_Decl); |
df3e68b1 | 6626 | end if; |
937e9676 | 6627 | end Process_Transients_In_Scope; |
70482933 | 6628 | |
8e888920 AC |
6629 | -- Local variables |
6630 | ||
6631 | Loc : constant Source_Ptr := Sloc (N); | |
6632 | Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; | |
6633 | First_Obj : Node_Id; | |
6634 | Last_Obj : Node_Id; | |
6635 | Mark_Id : Entity_Id; | |
6636 | Target : Node_Id; | |
6637 | ||
df3e68b1 | 6638 | -- Start of processing for Insert_Actions_In_Scope_Around |
70482933 | 6639 | |
df3e68b1 | 6640 | begin |
ed323421 | 6641 | -- Nothing to do if the scope does not manage the secondary stack or |
b7e68e7d | 6642 | -- does not contain meaningful actions for insertion. |
ed323421 AC |
6643 | |
6644 | if not Manage_SS | |
6645 | and then No (Act_Before) | |
6646 | and then No (Act_After) | |
6647 | and then No (Act_Cleanup) | |
6648 | then | |
df3e68b1 | 6649 | return; |
fbf5a39b | 6650 | end if; |
70482933 | 6651 | |
8e888920 AC |
6652 | -- If the node to be wrapped is the trigger of an asynchronous select, |
6653 | -- it is not part of a statement list. The actions must be inserted | |
6654 | -- before the select itself, which is part of some list of statements. | |
6655 | -- Note that the triggering alternative includes the triggering | |
41c79d60 AC |
6656 | -- statement and an optional statement list. If the node to be |
6657 | -- wrapped is part of that list, the normal insertion applies. | |
70482933 | 6658 | |
8e888920 AC |
6659 | if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative |
6660 | and then not Is_List_Member (Node_To_Wrap) | |
6661 | then | |
6662 | Target := Parent (Parent (Node_To_Wrap)); | |
6663 | else | |
6664 | Target := N; | |
6665 | end if; | |
33c423c8 | 6666 | |
8e888920 AC |
6667 | First_Obj := Target; |
6668 | Last_Obj := Target; | |
33c423c8 | 6669 | |
8e888920 AC |
6670 | -- Add all actions associated with a transient scope into the main tree. |
6671 | -- There are several scenarios here: | |
2c1b72d7 | 6672 | |
8e888920 AC |
6673 | -- +--- Before ----+ +----- After ---+ |
6674 | -- 1) First_Obj ....... Target ........ Last_Obj | |
2c1b72d7 | 6675 | |
8e888920 | 6676 | -- 2) First_Obj ....... Target |
2c1b72d7 | 6677 | |
8e888920 | 6678 | -- 3) Target ........ Last_Obj |
9732e886 | 6679 | |
8e888920 | 6680 | -- Flag declarations are inserted before the first object |
9732e886 | 6681 | |
8e888920 AC |
6682 | if Present (Act_Before) then |
6683 | First_Obj := First (Act_Before); | |
6684 | Insert_List_Before (Target, Act_Before); | |
6685 | end if; | |
e8374e7a | 6686 | |
8e888920 | 6687 | -- Finalization calls are inserted after the last object |
e8374e7a | 6688 | |
8e888920 AC |
6689 | if Present (Act_After) then |
6690 | Last_Obj := Last (Act_After); | |
6691 | Insert_List_After (Target, Act_After); | |
6692 | end if; | |
33c423c8 | 6693 | |
8e888920 | 6694 | -- Mark and release the secondary stack when the context warrants it |
70482933 | 6695 | |
8e888920 AC |
6696 | if Manage_SS then |
6697 | Mark_Id := Make_Temporary (Loc, 'M'); | |
70482933 | 6698 | |
8e888920 AC |
6699 | -- Generate: |
6700 | -- Mnn : constant Mark_Id := SS_Mark; | |
afe4375b | 6701 | |
8e888920 AC |
6702 | Insert_Before_And_Analyze |
6703 | (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id)); | |
afe4375b | 6704 | |
8e888920 AC |
6705 | -- Generate: |
6706 | -- SS_Release (Mnn); | |
afe4375b | 6707 | |
8e888920 AC |
6708 | Insert_After_And_Analyze |
6709 | (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id)); | |
6710 | end if; | |
afe4375b | 6711 | |
937e9676 AC |
6712 | -- Check for transient objects associated with Target and generate the |
6713 | -- appropriate finalization actions for them. | |
afe4375b | 6714 | |
937e9676 | 6715 | Process_Transients_In_Scope |
8e888920 AC |
6716 | (First_Object => First_Obj, |
6717 | Last_Object => Last_Obj, | |
6718 | Related_Node => Target); | |
3aac5551 | 6719 | |
8e888920 AC |
6720 | -- Reset the action lists |
6721 | ||
6722 | Scope_Stack.Table | |
6723 | (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List; | |
6724 | Scope_Stack.Table | |
6725 | (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List; | |
6726 | ||
6727 | if Clean then | |
6728 | Scope_Stack.Table | |
6729 | (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List; | |
6730 | end if; | |
df3e68b1 | 6731 | end Insert_Actions_In_Scope_Around; |
afe4375b | 6732 | |
df3e68b1 HK |
6733 | ------------------------------ |
6734 | -- Is_Simple_Protected_Type -- | |
6735 | ------------------------------ | |
afe4375b | 6736 | |
df3e68b1 HK |
6737 | function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is |
6738 | begin | |
6739 | return | |
6740 | Is_Protected_Type (T) | |
88e7531b | 6741 | and then not Uses_Lock_Free (T) |
df3e68b1 HK |
6742 | and then not Has_Entries (T) |
6743 | and then Is_RTE (Find_Protection_Type (T), RE_Protection); | |
6744 | end Is_Simple_Protected_Type; | |
afe4375b | 6745 | |
df3e68b1 HK |
6746 | ----------------------- |
6747 | -- Make_Adjust_Call -- | |
6748 | ----------------------- | |
afe4375b | 6749 | |
df3e68b1 | 6750 | function Make_Adjust_Call |
4ac2bbbd AC |
6751 | (Obj_Ref : Node_Id; |
6752 | Typ : Entity_Id; | |
6753 | Skip_Self : Boolean := False) return Node_Id | |
df3e68b1 HK |
6754 | is |
6755 | Loc : constant Source_Ptr := Sloc (Obj_Ref); | |
6756 | Adj_Id : Entity_Id := Empty; | |
2168d7cc | 6757 | Ref : Node_Id; |
df3e68b1 | 6758 | Utyp : Entity_Id; |
afe4375b | 6759 | |
df3e68b1 | 6760 | begin |
2168d7cc AC |
6761 | Ref := Obj_Ref; |
6762 | ||
df3e68b1 | 6763 | -- Recover the proper type which contains Deep_Adjust |
afe4375b | 6764 | |
df3e68b1 HK |
6765 | if Is_Class_Wide_Type (Typ) then |
6766 | Utyp := Root_Type (Typ); | |
6767 | else | |
6768 | Utyp := Typ; | |
6769 | end if; | |
afe4375b | 6770 | |
df3e68b1 HK |
6771 | Utyp := Underlying_Type (Base_Type (Utyp)); |
6772 | Set_Assignment_OK (Ref); | |
afe4375b | 6773 | |
1fb63e89 | 6774 | -- Deal with untagged derivation of private views |
afe4375b | 6775 | |
2168d7cc | 6776 | if Present (Utyp) and then Is_Untagged_Derivation (Typ) then |
df3e68b1 HK |
6777 | Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); |
6778 | Ref := Unchecked_Convert_To (Utyp, Ref); | |
6779 | Set_Assignment_OK (Ref); | |
6780 | end if; | |
afe4375b | 6781 | |
df3e68b1 HK |
6782 | -- When dealing with the completion of a private type, use the base |
6783 | -- type instead. | |
afe4375b | 6784 | |
2168d7cc | 6785 | if Present (Utyp) and then Utyp /= Base_Type (Utyp) then |
df3e68b1 | 6786 | pragma Assert (Is_Private_Type (Typ)); |
afe4375b | 6787 | |
df3e68b1 HK |
6788 | Utyp := Base_Type (Utyp); |
6789 | Ref := Unchecked_Convert_To (Utyp, Ref); | |
70482933 RK |
6790 | end if; |
6791 | ||
2168d7cc AC |
6792 | -- The underlying type may not be present due to a missing full view. In |
6793 | -- this case freezing did not take place and there is no [Deep_]Adjust | |
6794 | -- primitive to call. | |
6795 | ||
6796 | if No (Utyp) then | |
6797 | return Empty; | |
6798 | ||
6799 | elsif Skip_Self then | |
df3e68b1 | 6800 | if Has_Controlled_Component (Utyp) then |
4ac2bbbd | 6801 | if Is_Tagged_Type (Utyp) then |
ca811241 | 6802 | Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
4ac2bbbd AC |
6803 | else |
6804 | Adj_Id := TSS (Utyp, TSS_Deep_Adjust); | |
6805 | end if; | |
df3e68b1 | 6806 | end if; |
9732e886 | 6807 | |
d3cb4cc0 | 6808 | -- Class-wide types, interfaces and types with controlled components |
e8374e7a | 6809 | |
df3e68b1 | 6810 | elsif Is_Class_Wide_Type (Typ) |
d3cb4cc0 | 6811 | or else Is_Interface (Typ) |
df3e68b1 HK |
6812 | or else Has_Controlled_Component (Utyp) |
6813 | then | |
6814 | if Is_Tagged_Type (Utyp) then | |
ca811241 | 6815 | Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
df3e68b1 HK |
6816 | else |
6817 | Adj_Id := TSS (Utyp, TSS_Deep_Adjust); | |
6818 | end if; | |
9732e886 | 6819 | |
d3cb4cc0 AC |
6820 | -- Derivations from [Limited_]Controlled |
6821 | ||
6822 | elsif Is_Controlled (Utyp) then | |
6823 | if Has_Controlled_Component (Utyp) then | |
ca811241 | 6824 | Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
d3cb4cc0 | 6825 | else |
ca811241 | 6826 | Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case)); |
d3cb4cc0 AC |
6827 | end if; |
6828 | ||
6829 | -- Tagged types | |
6830 | ||
6831 | elsif Is_Tagged_Type (Utyp) then | |
ca811241 | 6832 | Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); |
9732e886 | 6833 | |
df3e68b1 | 6834 | else |
d3cb4cc0 | 6835 | raise Program_Error; |
df3e68b1 | 6836 | end if; |
e8374e7a | 6837 | |
df3e68b1 | 6838 | if Present (Adj_Id) then |
e8374e7a | 6839 | |
df3e68b1 HK |
6840 | -- If the object is unanalyzed, set its expected type for use in |
6841 | -- Convert_View in case an additional conversion is needed. | |
9732e886 | 6842 | |
df3e68b1 HK |
6843 | if No (Etype (Ref)) |
6844 | and then Nkind (Ref) /= N_Unchecked_Type_Conversion | |
6845 | then | |
6846 | Set_Etype (Ref, Typ); | |
9732e886 | 6847 | end if; |
33c423c8 | 6848 | |
df3e68b1 HK |
6849 | -- The object reference may need another conversion depending on the |
6850 | -- type of the formal and that of the actual. | |
70482933 | 6851 | |
df3e68b1 HK |
6852 | if not Is_Class_Wide_Type (Typ) then |
6853 | Ref := Convert_View (Adj_Id, Ref); | |
6854 | end if; | |
70482933 | 6855 | |
4ac2bbbd AC |
6856 | return |
6857 | Make_Call (Loc, | |
6858 | Proc_Id => Adj_Id, | |
2168d7cc | 6859 | Param => Ref, |
4ac2bbbd | 6860 | Skip_Self => Skip_Self); |
df3e68b1 HK |
6861 | else |
6862 | return Empty; | |
6863 | end if; | |
6864 | end Make_Adjust_Call; | |
70482933 | 6865 | |
df3e68b1 HK |
6866 | --------------- |
6867 | -- Make_Call -- | |
6868 | --------------- | |
70482933 | 6869 | |
df3e68b1 | 6870 | function Make_Call |
4ac2bbbd AC |
6871 | (Loc : Source_Ptr; |
6872 | Proc_Id : Entity_Id; | |
6873 | Param : Node_Id; | |
6874 | Skip_Self : Boolean := False) return Node_Id | |
70482933 | 6875 | is |
df3e68b1 | 6876 | Params : constant List_Id := New_List (Param); |
70482933 RK |
6877 | |
6878 | begin | |
4ac2bbbd AC |
6879 | -- Do not apply the controlled action to the object itself by signaling |
6880 | -- the related routine to avoid self. | |
dcfa065d | 6881 | |
4ac2bbbd | 6882 | if Skip_Self then |
e4494292 | 6883 | Append_To (Params, New_Occurrence_Of (Standard_False, Loc)); |
df3e68b1 | 6884 | end if; |
dcfa065d | 6885 | |
df3e68b1 HK |
6886 | return |
6887 | Make_Procedure_Call_Statement (Loc, | |
e4494292 | 6888 | Name => New_Occurrence_Of (Proc_Id, Loc), |
df3e68b1 HK |
6889 | Parameter_Associations => Params); |
6890 | end Make_Call; | |
70482933 | 6891 | |
df3e68b1 HK |
6892 | -------------------------- |
6893 | -- Make_Deep_Array_Body -- | |
6894 | -------------------------- | |
70482933 | 6895 | |
df3e68b1 HK |
6896 | function Make_Deep_Array_Body |
6897 | (Prim : Final_Primitives; | |
6898 | Typ : Entity_Id) return List_Id | |
6899 | is | |
6900 | function Build_Adjust_Or_Finalize_Statements | |
6901 | (Typ : Entity_Id) return List_Id; | |
6902 | -- Create the statements necessary to adjust or finalize an array of | |
6903 | -- controlled elements. Generate: | |
cfae2bed | 6904 | -- |
df3e68b1 | 6905 | -- declare |
14848f57 | 6906 | -- Abort : constant Boolean := Triggered_By_Abort; |
f9ad6b62 AC |
6907 | -- <or> |
6908 | -- Abort : constant Boolean := False; -- no abort | |
cfae2bed | 6909 | -- |
df3e68b1 HK |
6910 | -- E : Exception_Occurrence; |
6911 | -- Raised : Boolean := False; | |
cfae2bed | 6912 | -- |
df3e68b1 HK |
6913 | -- begin |
6914 | -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop | |
6915 | -- ^-- in the finalization case | |
6916 | -- ... | |
6917 | -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop | |
6918 | -- begin | |
6919 | -- [Deep_]Adjust / Finalize (V (J1, ..., Jn)); | |
cfae2bed | 6920 | -- |
df3e68b1 HK |
6921 | -- exception |
6922 | -- when others => | |
6923 | -- if not Raised then | |
6924 | -- Raised := True; | |
6925 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
6926 | -- end if; | |
6927 | -- end; | |
6928 | -- end loop; | |
6929 | -- ... | |
6930 | -- end loop; | |
cfae2bed | 6931 | -- |
ca5af305 AC |
6932 | -- if Raised and then not Abort then |
6933 | -- Raise_From_Controlled_Operation (E); | |
df3e68b1 HK |
6934 | -- end if; |
6935 | -- end; | |
6936 | ||
6937 | function Build_Initialize_Statements (Typ : Entity_Id) return List_Id; | |
6938 | -- Create the statements necessary to initialize an array of controlled | |
6939 | -- elements. Include a mechanism to carry out partial finalization if an | |
6940 | -- exception occurs. Generate: | |
cfae2bed | 6941 | -- |
df3e68b1 HK |
6942 | -- declare |
6943 | -- Counter : Integer := 0; | |
cfae2bed | 6944 | -- |
df3e68b1 HK |
6945 | -- begin |
6946 | -- for J1 in V'Range (1) loop | |
6947 | -- ... | |
6948 | -- for JN in V'Range (N) loop | |
6949 | -- begin | |
6950 | -- [Deep_]Initialize (V (J1, ..., JN)); | |
cfae2bed | 6951 | -- |
df3e68b1 | 6952 | -- Counter := Counter + 1; |
cfae2bed | 6953 | -- |
df3e68b1 HK |
6954 | -- exception |
6955 | -- when others => | |
6956 | -- declare | |
14848f57 | 6957 | -- Abort : constant Boolean := Triggered_By_Abort; |
f9ad6b62 AC |
6958 | -- <or> |
6959 | -- Abort : constant Boolean := False; -- no abort | |
7f37fff1 | 6960 | -- E : Exception_Occurrence; |
df3e68b1 HK |
6961 | -- Raised : Boolean := False; |
6962 | ||
6963 | -- begin | |
6964 | -- Counter := | |
6965 | -- V'Length (1) * | |
6966 | -- V'Length (2) * | |
6967 | -- ... | |
6968 | -- V'Length (N) - Counter; | |
6969 | ||
6970 | -- for F1 in reverse V'Range (1) loop | |
6971 | -- ... | |
6972 | -- for FN in reverse V'Range (N) loop | |
6973 | -- if Counter > 0 then | |
6974 | -- Counter := Counter - 1; | |
6975 | -- else | |
6976 | -- begin | |
6977 | -- [Deep_]Finalize (V (F1, ..., FN)); | |
6978 | ||
6979 | -- exception | |
6980 | -- when others => | |
6981 | -- if not Raised then | |
6982 | -- Raised := True; | |
6983 | -- Save_Occurrence (E, | |
6984 | -- Get_Current_Excep.all.all); | |
6985 | -- end if; | |
6986 | -- end; | |
6987 | -- end if; | |
6988 | -- end loop; | |
6989 | -- ... | |
6990 | -- end loop; | |
6991 | -- end; | |
886b5a18 | 6992 | -- |
ca5af305 AC |
6993 | -- if Raised and then not Abort then |
6994 | -- Raise_From_Controlled_Operation (E); | |
df3e68b1 | 6995 | -- end if; |
886b5a18 | 6996 | -- |
df3e68b1 HK |
6997 | -- raise; |
6998 | -- end; | |
6999 | -- end loop; | |
7000 | -- end loop; | |
7001 | -- end; | |
7002 | ||
7003 | function New_References_To | |
7004 | (L : List_Id; | |
7005 | Loc : Source_Ptr) return List_Id; | |
7006 | -- Given a list of defining identifiers, return a list of references to | |
7007 | -- the original identifiers, in the same order as they appear. | |
7008 | ||
7009 | ----------------------------------------- | |
7010 | -- Build_Adjust_Or_Finalize_Statements -- | |
7011 | ----------------------------------------- | |
7012 | ||
7013 | function Build_Adjust_Or_Finalize_Statements | |
7014 | (Typ : Entity_Id) return List_Id | |
7015 | is | |
321c24f7 AC |
7016 | Comp_Typ : constant Entity_Id := Component_Type (Typ); |
7017 | Index_List : constant List_Id := New_List; | |
7018 | Loc : constant Source_Ptr := Sloc (Typ); | |
7019 | Num_Dims : constant Int := Number_Dimensions (Typ); | |
df3e68b1 | 7020 | |
d0ef7921 AC |
7021 | procedure Build_Indexes; |
7022 | -- Generate the indexes used in the dimension loops | |
df3e68b1 HK |
7023 | |
7024 | ------------------- | |
d0ef7921 | 7025 | -- Build_Indexes -- |
df3e68b1 HK |
7026 | ------------------- |
7027 | ||
d0ef7921 | 7028 | procedure Build_Indexes is |
df3e68b1 HK |
7029 | begin |
7030 | -- Generate the following identifiers: | |
7031 | -- Jnn - for initialization | |
70482933 | 7032 | |
df3e68b1 HK |
7033 | for Dim in 1 .. Num_Dims loop |
7034 | Append_To (Index_List, | |
7035 | Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); | |
7036 | end loop; | |
d0ef7921 | 7037 | end Build_Indexes; |
70482933 | 7038 | |
2168d7cc AC |
7039 | -- Local variables |
7040 | ||
7041 | Final_Decls : List_Id := No_List; | |
7042 | Final_Data : Finalization_Exception_Data; | |
7043 | Block : Node_Id; | |
7044 | Call : Node_Id; | |
7045 | Comp_Ref : Node_Id; | |
7046 | Core_Loop : Node_Id; | |
7047 | Dim : Int; | |
7048 | J : Entity_Id; | |
7049 | Loop_Id : Entity_Id; | |
7050 | Stmts : List_Id; | |
7051 | ||
df3e68b1 | 7052 | -- Start of processing for Build_Adjust_Or_Finalize_Statements |
70482933 | 7053 | |
df3e68b1 | 7054 | begin |
2168d7cc | 7055 | Final_Decls := New_List; |
70482933 | 7056 | |
d0ef7921 | 7057 | Build_Indexes; |
2168d7cc | 7058 | Build_Object_Declarations (Final_Data, Final_Decls, Loc); |
dcfa065d | 7059 | |
df3e68b1 HK |
7060 | Comp_Ref := |
7061 | Make_Indexed_Component (Loc, | |
2c1b72d7 AC |
7062 | Prefix => Make_Identifier (Loc, Name_V), |
7063 | Expressions => New_References_To (Index_List, Loc)); | |
df3e68b1 | 7064 | Set_Etype (Comp_Ref, Comp_Typ); |
dcfa065d | 7065 | |
df3e68b1 HK |
7066 | -- Generate: |
7067 | -- [Deep_]Adjust (V (J1, ..., JN)) | |
70482933 | 7068 | |
df3e68b1 | 7069 | if Prim = Adjust_Case then |
2c1b72d7 | 7070 | Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
70482933 | 7071 | |
df3e68b1 HK |
7072 | -- Generate: |
7073 | -- [Deep_]Finalize (V (J1, ..., JN)) | |
70482933 | 7074 | |
df3e68b1 | 7075 | else pragma Assert (Prim = Finalize_Case); |
2c1b72d7 | 7076 | Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
df3e68b1 | 7077 | end if; |
70482933 | 7078 | |
2168d7cc | 7079 | if Present (Call) then |
c5288c90 | 7080 | |
2168d7cc | 7081 | -- Generate the block which houses the adjust or finalize call: |
c5288c90 | 7082 | |
2168d7cc AC |
7083 | -- begin |
7084 | -- <adjust or finalize call> | |
c5288c90 | 7085 | |
2168d7cc AC |
7086 | -- exception |
7087 | -- when others => | |
7088 | -- if not Raised then | |
7089 | -- Raised := True; | |
7090 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7091 | -- end if; | |
7092 | -- end; | |
c5288c90 | 7093 | |
2168d7cc AC |
7094 | if Exceptions_OK then |
7095 | Core_Loop := | |
7096 | Make_Block_Statement (Loc, | |
7097 | Handled_Statement_Sequence => | |
7098 | Make_Handled_Sequence_Of_Statements (Loc, | |
7099 | Statements => New_List (Call), | |
7100 | Exception_Handlers => New_List ( | |
7101 | Build_Exception_Handler (Final_Data)))); | |
7102 | else | |
7103 | Core_Loop := Call; | |
7104 | end if; | |
70482933 | 7105 | |
2168d7cc AC |
7106 | -- Generate the dimension loops starting from the innermost one |
7107 | ||
7108 | -- for Jnn in [reverse] V'Range (Dim) loop | |
7109 | -- <core loop> | |
7110 | -- end loop; | |
7111 | ||
7112 | J := Last (Index_List); | |
7113 | Dim := Num_Dims; | |
7114 | while Present (J) and then Dim > 0 loop | |
7115 | Loop_Id := J; | |
7116 | Prev (J); | |
7117 | Remove (Loop_Id); | |
7118 | ||
7119 | Core_Loop := | |
7120 | Make_Loop_Statement (Loc, | |
7121 | Iteration_Scheme => | |
7122 | Make_Iteration_Scheme (Loc, | |
7123 | Loop_Parameter_Specification => | |
7124 | Make_Loop_Parameter_Specification (Loc, | |
7125 | Defining_Identifier => Loop_Id, | |
7126 | Discrete_Subtype_Definition => | |
7127 | Make_Attribute_Reference (Loc, | |
7128 | Prefix => Make_Identifier (Loc, Name_V), | |
7129 | Attribute_Name => Name_Range, | |
7130 | Expressions => New_List ( | |
7131 | Make_Integer_Literal (Loc, Dim))), | |
7132 | ||
7133 | Reverse_Present => | |
7134 | Prim = Finalize_Case)), | |
7135 | ||
7136 | Statements => New_List (Core_Loop), | |
7137 | End_Label => Empty); | |
7138 | ||
7139 | Dim := Dim - 1; | |
7140 | end loop; | |
70482933 | 7141 | |
2168d7cc AC |
7142 | -- Generate the block which contains the core loop, declarations |
7143 | -- of the abort flag, the exception occurrence, the raised flag | |
7144 | -- and the conditional raise: | |
70482933 | 7145 | |
2168d7cc AC |
7146 | -- declare |
7147 | -- Abort : constant Boolean := Triggered_By_Abort; | |
7148 | -- <or> | |
7149 | -- Abort : constant Boolean := False; -- no abort | |
70482933 | 7150 | |
2168d7cc AC |
7151 | -- E : Exception_Occurrence; |
7152 | -- Raised : Boolean := False; | |
70482933 | 7153 | |
2168d7cc AC |
7154 | -- begin |
7155 | -- <core loop> | |
70482933 | 7156 | |
2168d7cc AC |
7157 | -- if Raised and then not Abort then |
7158 | -- Raise_From_Controlled_Operation (E); | |
7159 | -- end if; | |
7160 | -- end; | |
f9ad6b62 | 7161 | |
2168d7cc | 7162 | Stmts := New_List (Core_Loop); |
70482933 | 7163 | |
2168d7cc AC |
7164 | if Exceptions_OK then |
7165 | Append_To (Stmts, Build_Raise_Statement (Final_Data)); | |
7166 | end if; | |
70482933 | 7167 | |
2168d7cc AC |
7168 | Block := |
7169 | Make_Block_Statement (Loc, | |
7170 | Declarations => Final_Decls, | |
7171 | Handled_Statement_Sequence => | |
7172 | Make_Handled_Sequence_Of_Statements (Loc, | |
7173 | Statements => Stmts)); | |
70482933 | 7174 | |
2168d7cc AC |
7175 | -- Otherwise previous errors or a missing full view may prevent the |
7176 | -- proper freezing of the component type. If this is the case, there | |
7177 | -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call. | |
70482933 | 7178 | |
2168d7cc AC |
7179 | else |
7180 | Block := Make_Null_Statement (Loc); | |
df3e68b1 | 7181 | end if; |
70482933 | 7182 | |
2168d7cc | 7183 | return New_List (Block); |
df3e68b1 HK |
7184 | end Build_Adjust_Or_Finalize_Statements; |
7185 | ||
7186 | --------------------------------- | |
7187 | -- Build_Initialize_Statements -- | |
7188 | --------------------------------- | |
7189 | ||
7190 | function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is | |
321c24f7 AC |
7191 | Comp_Typ : constant Entity_Id := Component_Type (Typ); |
7192 | Final_List : constant List_Id := New_List; | |
7193 | Index_List : constant List_Id := New_List; | |
7194 | Loc : constant Source_Ptr := Sloc (Typ); | |
7195 | Num_Dims : constant Int := Number_Dimensions (Typ); | |
df3e68b1 | 7196 | |
2168d7cc | 7197 | function Build_Assignment (Counter_Id : Entity_Id) return Node_Id; |
df3e68b1 HK |
7198 | -- Generate the following assignment: |
7199 | -- Counter := V'Length (1) * | |
7200 | -- ... | |
7201 | -- V'Length (N) - Counter; | |
2168d7cc AC |
7202 | -- |
7203 | -- Counter_Id denotes the entity of the counter. | |
df3e68b1 HK |
7204 | |
7205 | function Build_Finalization_Call return Node_Id; | |
7206 | -- Generate a deep finalization call for an array element | |
7207 | ||
d0ef7921 AC |
7208 | procedure Build_Indexes; |
7209 | -- Generate the initialization and finalization indexes used in the | |
df3e68b1 HK |
7210 | -- dimension loops. |
7211 | ||
7212 | function Build_Initialization_Call return Node_Id; | |
7213 | -- Generate a deep initialization call for an array element | |
7214 | ||
2168d7cc AC |
7215 | ---------------------- |
7216 | -- Build_Assignment -- | |
7217 | ---------------------- | |
df3e68b1 | 7218 | |
2168d7cc | 7219 | function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is |
df3e68b1 HK |
7220 | Dim : Int; |
7221 | Expr : Node_Id; | |
70482933 | 7222 | |
df3e68b1 HK |
7223 | begin |
7224 | -- Start from the first dimension and generate: | |
7225 | -- V'Length (1) | |
70482933 | 7226 | |
df3e68b1 HK |
7227 | Dim := 1; |
7228 | Expr := | |
7229 | Make_Attribute_Reference (Loc, | |
cfae2bed AC |
7230 | Prefix => Make_Identifier (Loc, Name_V), |
7231 | Attribute_Name => Name_Length, | |
7232 | Expressions => New_List (Make_Integer_Literal (Loc, Dim))); | |
df3e68b1 HK |
7233 | |
7234 | -- Process the rest of the dimensions, generate: | |
7235 | -- Expr * V'Length (N) | |
7236 | ||
7237 | Dim := Dim + 1; | |
7238 | while Dim <= Num_Dims loop | |
7239 | Expr := | |
7240 | Make_Op_Multiply (Loc, | |
2c1b72d7 | 7241 | Left_Opnd => Expr, |
df3e68b1 HK |
7242 | Right_Opnd => |
7243 | Make_Attribute_Reference (Loc, | |
2c1b72d7 AC |
7244 | Prefix => Make_Identifier (Loc, Name_V), |
7245 | Attribute_Name => Name_Length, | |
7246 | Expressions => New_List ( | |
df3e68b1 HK |
7247 | Make_Integer_Literal (Loc, Dim)))); |
7248 | ||
7249 | Dim := Dim + 1; | |
7250 | end loop; | |
70482933 | 7251 | |
df3e68b1 HK |
7252 | -- Generate: |
7253 | -- Counter := Expr - Counter; | |
70482933 | 7254 | |
df3e68b1 HK |
7255 | return |
7256 | Make_Assignment_Statement (Loc, | |
e4494292 | 7257 | Name => New_Occurrence_Of (Counter_Id, Loc), |
df3e68b1 HK |
7258 | Expression => |
7259 | Make_Op_Subtract (Loc, | |
2c1b72d7 | 7260 | Left_Opnd => Expr, |
e4494292 | 7261 | Right_Opnd => New_Occurrence_Of (Counter_Id, Loc))); |
2168d7cc | 7262 | end Build_Assignment; |
df3e68b1 HK |
7263 | |
7264 | ----------------------------- | |
7265 | -- Build_Finalization_Call -- | |
7266 | ----------------------------- | |
7267 | ||
7268 | function Build_Finalization_Call return Node_Id is | |
7269 | Comp_Ref : constant Node_Id := | |
7270 | Make_Indexed_Component (Loc, | |
2c1b72d7 AC |
7271 | Prefix => Make_Identifier (Loc, Name_V), |
7272 | Expressions => New_References_To (Final_List, Loc)); | |
70482933 | 7273 | |
df3e68b1 HK |
7274 | begin |
7275 | Set_Etype (Comp_Ref, Comp_Typ); | |
70482933 | 7276 | |
df3e68b1 HK |
7277 | -- Generate: |
7278 | -- [Deep_]Finalize (V); | |
70482933 | 7279 | |
2c1b72d7 | 7280 | return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
df3e68b1 | 7281 | end Build_Finalization_Call; |
70482933 | 7282 | |
df3e68b1 | 7283 | ------------------- |
d0ef7921 | 7284 | -- Build_Indexes -- |
df3e68b1 | 7285 | ------------------- |
70482933 | 7286 | |
d0ef7921 | 7287 | procedure Build_Indexes is |
df3e68b1 HK |
7288 | begin |
7289 | -- Generate the following identifiers: | |
7290 | -- Jnn - for initialization | |
7291 | -- Fnn - for finalization | |
f4d379b8 | 7292 | |
df3e68b1 HK |
7293 | for Dim in 1 .. Num_Dims loop |
7294 | Append_To (Index_List, | |
7295 | Make_Defining_Identifier (Loc, New_External_Name ('J', Dim))); | |
f4d379b8 | 7296 | |
df3e68b1 HK |
7297 | Append_To (Final_List, |
7298 | Make_Defining_Identifier (Loc, New_External_Name ('F', Dim))); | |
7299 | end loop; | |
d0ef7921 | 7300 | end Build_Indexes; |
70482933 | 7301 | |
df3e68b1 HK |
7302 | ------------------------------- |
7303 | -- Build_Initialization_Call -- | |
7304 | ------------------------------- | |
70482933 | 7305 | |
df3e68b1 HK |
7306 | function Build_Initialization_Call return Node_Id is |
7307 | Comp_Ref : constant Node_Id := | |
7308 | Make_Indexed_Component (Loc, | |
cfae2bed AC |
7309 | Prefix => Make_Identifier (Loc, Name_V), |
7310 | Expressions => New_References_To (Index_List, Loc)); | |
70482933 | 7311 | |
df3e68b1 HK |
7312 | begin |
7313 | Set_Etype (Comp_Ref, Comp_Typ); | |
7314 | ||
7315 | -- Generate: | |
7316 | -- [Deep_]Initialize (V (J1, ..., JN)); | |
70482933 | 7317 | |
2c1b72d7 | 7318 | return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); |
df3e68b1 | 7319 | end Build_Initialization_Call; |
70482933 | 7320 | |
2168d7cc AC |
7321 | -- Local variables |
7322 | ||
7323 | Counter_Id : Entity_Id; | |
7324 | Dim : Int; | |
7325 | F : Node_Id; | |
7326 | Fin_Stmt : Node_Id; | |
7327 | Final_Block : Node_Id; | |
7328 | Final_Data : Finalization_Exception_Data; | |
7329 | Final_Decls : List_Id := No_List; | |
7330 | Final_Loop : Node_Id; | |
7331 | Init_Block : Node_Id; | |
7332 | Init_Call : Node_Id; | |
7333 | Init_Loop : Node_Id; | |
7334 | J : Node_Id; | |
7335 | Loop_Id : Node_Id; | |
7336 | Stmts : List_Id; | |
7337 | ||
df3e68b1 | 7338 | -- Start of processing for Build_Initialize_Statements |
70482933 | 7339 | |
df3e68b1 | 7340 | begin |
2168d7cc AC |
7341 | Counter_Id := Make_Temporary (Loc, 'C'); |
7342 | Final_Decls := New_List; | |
70482933 | 7343 | |
d0ef7921 | 7344 | Build_Indexes; |
2168d7cc | 7345 | Build_Object_Declarations (Final_Data, Final_Decls, Loc); |
70482933 | 7346 | |
df3e68b1 HK |
7347 | -- Generate the block which houses the finalization call, the index |
7348 | -- guard and the handler which triggers Program_Error later on. | |
7349 | ||
7350 | -- if Counter > 0 then | |
7351 | -- Counter := Counter - 1; | |
7352 | -- else | |
7bf911b5 | 7353 | -- begin |
df3e68b1 HK |
7354 | -- [Deep_]Finalize (V (F1, ..., FN)); |
7355 | -- exception | |
7356 | -- when others => | |
7357 | -- if not Raised then | |
7358 | -- Raised := True; | |
7359 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7360 | -- end if; | |
7361 | -- end; | |
7362 | -- end if; | |
7363 | ||
2168d7cc | 7364 | Fin_Stmt := Build_Finalization_Call; |
df3e68b1 | 7365 | |
2168d7cc AC |
7366 | if Present (Fin_Stmt) then |
7367 | if Exceptions_OK then | |
7368 | Fin_Stmt := | |
7369 | Make_Block_Statement (Loc, | |
7370 | Handled_Statement_Sequence => | |
7371 | Make_Handled_Sequence_Of_Statements (Loc, | |
7372 | Statements => New_List (Fin_Stmt), | |
7373 | Exception_Handlers => New_List ( | |
7374 | Build_Exception_Handler (Final_Data)))); | |
7375 | end if; | |
df3e68b1 | 7376 | |
2168d7cc AC |
7377 | -- This is the core of the loop, the dimension iterators are added |
7378 | -- one by one in reverse. | |
70482933 | 7379 | |
df3e68b1 | 7380 | Final_Loop := |
2168d7cc AC |
7381 | Make_If_Statement (Loc, |
7382 | Condition => | |
7383 | Make_Op_Gt (Loc, | |
7384 | Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), | |
7385 | Right_Opnd => Make_Integer_Literal (Loc, 0)), | |
7386 | ||
7387 | Then_Statements => New_List ( | |
7388 | Make_Assignment_Statement (Loc, | |
7389 | Name => New_Occurrence_Of (Counter_Id, Loc), | |
7390 | Expression => | |
7391 | Make_Op_Subtract (Loc, | |
7392 | Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), | |
7393 | Right_Opnd => Make_Integer_Literal (Loc, 1)))), | |
7394 | ||
7395 | Else_Statements => New_List (Fin_Stmt)); | |
7396 | ||
7397 | -- Generate all finalization loops starting from the innermost | |
7398 | -- dimension. | |
7399 | ||
7400 | -- for Fnn in reverse V'Range (Dim) loop | |
7401 | -- <final loop> | |
7402 | -- end loop; | |
7403 | ||
7404 | F := Last (Final_List); | |
7405 | Dim := Num_Dims; | |
7406 | while Present (F) and then Dim > 0 loop | |
7407 | Loop_Id := F; | |
7408 | Prev (F); | |
7409 | Remove (Loop_Id); | |
7410 | ||
7411 | Final_Loop := | |
7412 | Make_Loop_Statement (Loc, | |
7413 | Iteration_Scheme => | |
7414 | Make_Iteration_Scheme (Loc, | |
7415 | Loop_Parameter_Specification => | |
7416 | Make_Loop_Parameter_Specification (Loc, | |
7417 | Defining_Identifier => Loop_Id, | |
7418 | Discrete_Subtype_Definition => | |
7419 | Make_Attribute_Reference (Loc, | |
7420 | Prefix => Make_Identifier (Loc, Name_V), | |
7421 | Attribute_Name => Name_Range, | |
7422 | Expressions => New_List ( | |
7423 | Make_Integer_Literal (Loc, Dim))), | |
7424 | ||
7425 | Reverse_Present => True)), | |
7426 | ||
7427 | Statements => New_List (Final_Loop), | |
7428 | End_Label => Empty); | |
7429 | ||
7430 | Dim := Dim - 1; | |
7431 | end loop; | |
70482933 | 7432 | |
2168d7cc AC |
7433 | -- Generate the block which contains the finalization loops, the |
7434 | -- declarations of the abort flag, the exception occurrence, the | |
7435 | -- raised flag and the conditional raise. | |
70482933 | 7436 | |
2168d7cc AC |
7437 | -- declare |
7438 | -- Abort : constant Boolean := Triggered_By_Abort; | |
7439 | -- <or> | |
7440 | -- Abort : constant Boolean := False; -- no abort | |
70482933 | 7441 | |
2168d7cc AC |
7442 | -- E : Exception_Occurrence; |
7443 | -- Raised : Boolean := False; | |
70482933 | 7444 | |
2168d7cc AC |
7445 | -- begin |
7446 | -- Counter := | |
7447 | -- V'Length (1) * | |
7448 | -- ... | |
7449 | -- V'Length (N) - Counter; | |
70482933 | 7450 | |
2168d7cc | 7451 | -- <final loop> |
f9ad6b62 | 7452 | |
2168d7cc AC |
7453 | -- if Raised and then not Abort then |
7454 | -- Raise_From_Controlled_Operation (E); | |
7455 | -- end if; | |
70482933 | 7456 | |
2168d7cc AC |
7457 | -- raise; |
7458 | -- end; | |
70482933 | 7459 | |
2168d7cc | 7460 | Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop); |
70482933 | 7461 | |
2168d7cc AC |
7462 | if Exceptions_OK then |
7463 | Append_To (Stmts, Build_Raise_Statement (Final_Data)); | |
7464 | Append_To (Stmts, Make_Raise_Statement (Loc)); | |
7465 | end if; | |
70482933 | 7466 | |
2168d7cc AC |
7467 | Final_Block := |
7468 | Make_Block_Statement (Loc, | |
7469 | Declarations => Final_Decls, | |
7470 | Handled_Statement_Sequence => | |
7471 | Make_Handled_Sequence_Of_Statements (Loc, | |
7472 | Statements => Stmts)); | |
70482933 | 7473 | |
2168d7cc AC |
7474 | -- Otherwise previous errors or a missing full view may prevent the |
7475 | -- proper freezing of the component type. If this is the case, there | |
7476 | -- is no [Deep_]Finalize primitive to call. | |
df3e68b1 | 7477 | |
2168d7cc AC |
7478 | else |
7479 | Final_Block := Make_Null_Statement (Loc); | |
70482933 RK |
7480 | end if; |
7481 | ||
df3e68b1 HK |
7482 | -- Generate the block which contains the initialization call and |
7483 | -- the partial finalization code. | |
70482933 | 7484 | |
df3e68b1 HK |
7485 | -- begin |
7486 | -- [Deep_]Initialize (V (J1, ..., JN)); | |
70482933 | 7487 | |
df3e68b1 | 7488 | -- Counter := Counter + 1; |
70482933 | 7489 | |
df3e68b1 HK |
7490 | -- exception |
7491 | -- when others => | |
7492 | -- <finalization code> | |
7493 | -- end; | |
70482933 | 7494 | |
2168d7cc | 7495 | Init_Call := Build_Initialization_Call; |
70482933 | 7496 | |
097826df GD |
7497 | -- Only create finalization block if there is a nontrivial call |
7498 | -- to initialization or a Default_Initial_Condition check to be | |
7499 | -- performed. | |
7500 | ||
7501 | if (Present (Init_Call) | |
7502 | and then Nkind (Init_Call) /= N_Null_Statement) | |
7503 | or else | |
7504 | (Has_DIC (Comp_Typ) | |
7505 | and then not GNATprove_Mode | |
7506 | and then Present (DIC_Procedure (Comp_Typ)) | |
7507 | and then not Has_Null_Body (DIC_Procedure (Comp_Typ))) | |
1804faa4 | 7508 | then |
097826df GD |
7509 | declare |
7510 | Init_Stmts : constant List_Id := New_List; | |
7511 | ||
7512 | begin | |
7513 | if Present (Init_Call) then | |
7514 | Append_To (Init_Stmts, Init_Call); | |
7515 | end if; | |
7516 | ||
7517 | if Has_DIC (Comp_Typ) | |
7518 | and then Present (DIC_Procedure (Comp_Typ)) | |
7519 | then | |
7520 | Append_To | |
7521 | (Init_Stmts, | |
7522 | Build_DIC_Call (Loc, | |
7523 | Make_Indexed_Component (Loc, | |
7524 | Prefix => Make_Identifier (Loc, Name_V), | |
7525 | Expressions => New_References_To (Index_List, Loc)), | |
7526 | Comp_Typ)); | |
7527 | end if; | |
7528 | ||
7529 | Init_Loop := | |
7530 | Make_Block_Statement (Loc, | |
7531 | Handled_Statement_Sequence => | |
7532 | Make_Handled_Sequence_Of_Statements (Loc, | |
7533 | Statements => Init_Stmts, | |
7534 | Exception_Handlers => New_List ( | |
7535 | Make_Exception_Handler (Loc, | |
7536 | Exception_Choices => New_List ( | |
7537 | Make_Others_Choice (Loc)), | |
7538 | Statements => New_List (Final_Block))))); | |
7539 | end; | |
5d09245e | 7540 | |
2168d7cc AC |
7541 | Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), |
7542 | Make_Assignment_Statement (Loc, | |
7543 | Name => New_Occurrence_Of (Counter_Id, Loc), | |
7544 | Expression => | |
7545 | Make_Op_Add (Loc, | |
7546 | Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), | |
7547 | Right_Opnd => Make_Integer_Literal (Loc, 1)))); | |
7548 | ||
7549 | -- Generate all initialization loops starting from the innermost | |
7550 | -- dimension. | |
7551 | ||
7552 | -- for Jnn in V'Range (Dim) loop | |
7553 | -- <init loop> | |
7554 | -- end loop; | |
7555 | ||
7556 | J := Last (Index_List); | |
7557 | Dim := Num_Dims; | |
7558 | while Present (J) and then Dim > 0 loop | |
7559 | Loop_Id := J; | |
7560 | Prev (J); | |
7561 | Remove (Loop_Id); | |
7562 | ||
7563 | Init_Loop := | |
7564 | Make_Loop_Statement (Loc, | |
7565 | Iteration_Scheme => | |
7566 | Make_Iteration_Scheme (Loc, | |
7567 | Loop_Parameter_Specification => | |
7568 | Make_Loop_Parameter_Specification (Loc, | |
7569 | Defining_Identifier => Loop_Id, | |
7570 | Discrete_Subtype_Definition => | |
7571 | Make_Attribute_Reference (Loc, | |
7572 | Prefix => Make_Identifier (Loc, Name_V), | |
7573 | Attribute_Name => Name_Range, | |
7574 | Expressions => New_List ( | |
7575 | Make_Integer_Literal (Loc, Dim))))), | |
7576 | ||
7577 | Statements => New_List (Init_Loop), | |
7578 | End_Label => Empty); | |
7579 | ||
7580 | Dim := Dim - 1; | |
7581 | end loop; | |
70482933 | 7582 | |
2168d7cc AC |
7583 | -- Generate the block which contains the counter variable and the |
7584 | -- initialization loops. | |
70482933 | 7585 | |
2168d7cc AC |
7586 | -- declare |
7587 | -- Counter : Integer := 0; | |
7588 | -- begin | |
7589 | -- <init loop> | |
7590 | -- end; | |
70482933 | 7591 | |
2168d7cc AC |
7592 | Init_Block := |
7593 | Make_Block_Statement (Loc, | |
cfae2bed | 7594 | Declarations => New_List ( |
df3e68b1 HK |
7595 | Make_Object_Declaration (Loc, |
7596 | Defining_Identifier => Counter_Id, | |
2c1b72d7 | 7597 | Object_Definition => |
e4494292 | 7598 | New_Occurrence_Of (Standard_Integer, Loc), |
2c1b72d7 | 7599 | Expression => Make_Integer_Literal (Loc, 0))), |
df3e68b1 HK |
7600 | |
7601 | Handled_Statement_Sequence => | |
7602 | Make_Handled_Sequence_Of_Statements (Loc, | |
2168d7cc AC |
7603 | Statements => New_List (Init_Loop))); |
7604 | ||
bbf14e13 AC |
7605 | if Debug_Generated_Code then |
7606 | Set_Debug_Info_Needed (Counter_Id); | |
7607 | end if; | |
7608 | ||
2168d7cc AC |
7609 | -- Otherwise previous errors or a missing full view may prevent the |
7610 | -- proper freezing of the component type. If this is the case, there | |
7611 | -- is no [Deep_]Initialize primitive to call. | |
7612 | ||
7613 | else | |
7614 | Init_Block := Make_Null_Statement (Loc); | |
7615 | end if; | |
7616 | ||
7617 | return New_List (Init_Block); | |
df3e68b1 HK |
7618 | end Build_Initialize_Statements; |
7619 | ||
7620 | ----------------------- | |
7621 | -- New_References_To -- | |
7622 | ----------------------- | |
7623 | ||
7624 | function New_References_To | |
7625 | (L : List_Id; | |
7626 | Loc : Source_Ptr) return List_Id | |
7627 | is | |
7628 | Refs : constant List_Id := New_List; | |
7629 | Id : Node_Id; | |
70482933 | 7630 | |
df3e68b1 HK |
7631 | begin |
7632 | Id := First (L); | |
7633 | while Present (Id) loop | |
e4494292 | 7634 | Append_To (Refs, New_Occurrence_Of (Id, Loc)); |
df3e68b1 HK |
7635 | Next (Id); |
7636 | end loop; | |
70482933 | 7637 | |
df3e68b1 HK |
7638 | return Refs; |
7639 | end New_References_To; | |
70482933 | 7640 | |
df3e68b1 | 7641 | -- Start of processing for Make_Deep_Array_Body |
70482933 | 7642 | |
df3e68b1 HK |
7643 | begin |
7644 | case Prim is | |
7645 | when Address_Case => | |
7646 | return Make_Finalize_Address_Stmts (Typ); | |
70482933 | 7647 | |
d8f43ee6 HK |
7648 | when Adjust_Case |
7649 | | Finalize_Case | |
7650 | => | |
df3e68b1 | 7651 | return Build_Adjust_Or_Finalize_Statements (Typ); |
70482933 | 7652 | |
df3e68b1 HK |
7653 | when Initialize_Case => |
7654 | return Build_Initialize_Statements (Typ); | |
7655 | end case; | |
7656 | end Make_Deep_Array_Body; | |
70482933 | 7657 | |
df3e68b1 HK |
7658 | -------------------- |
7659 | -- Make_Deep_Proc -- | |
7660 | -------------------- | |
fbf5a39b | 7661 | |
df3e68b1 HK |
7662 | function Make_Deep_Proc |
7663 | (Prim : Final_Primitives; | |
7664 | Typ : Entity_Id; | |
7665 | Stmts : List_Id) return Entity_Id | |
7666 | is | |
7667 | Loc : constant Source_Ptr := Sloc (Typ); | |
7668 | Formals : List_Id; | |
7669 | Proc_Id : Entity_Id; | |
fbf5a39b | 7670 | |
df3e68b1 HK |
7671 | begin |
7672 | -- Create the object formal, generate: | |
7673 | -- V : System.Address | |
70482933 | 7674 | |
df3e68b1 HK |
7675 | if Prim = Address_Case then |
7676 | Formals := New_List ( | |
7677 | Make_Parameter_Specification (Loc, | |
2c1b72d7 | 7678 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
e4494292 RD |
7679 | Parameter_Type => |
7680 | New_Occurrence_Of (RTE (RE_Address), Loc))); | |
70482933 | 7681 | |
df3e68b1 | 7682 | -- Default case |
dfd99a80 | 7683 | |
df3e68b1 HK |
7684 | else |
7685 | -- V : in out Typ | |
7686 | ||
7687 | Formals := New_List ( | |
7688 | Make_Parameter_Specification (Loc, | |
2c1b72d7 AC |
7689 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
7690 | In_Present => True, | |
7691 | Out_Present => True, | |
e4494292 | 7692 | Parameter_Type => New_Occurrence_Of (Typ, Loc))); |
dfd99a80 | 7693 | |
df3e68b1 HK |
7694 | -- F : Boolean := True |
7695 | ||
7696 | if Prim = Adjust_Case | |
7697 | or else Prim = Finalize_Case | |
7698 | then | |
7699 | Append_To (Formals, | |
7700 | Make_Parameter_Specification (Loc, | |
2c1b72d7 AC |
7701 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), |
7702 | Parameter_Type => | |
e4494292 | 7703 | New_Occurrence_Of (Standard_Boolean, Loc), |
2c1b72d7 | 7704 | Expression => |
e4494292 | 7705 | New_Occurrence_Of (Standard_True, Loc))); |
dfd99a80 TQ |
7706 | end if; |
7707 | end if; | |
7708 | ||
df3e68b1 HK |
7709 | Proc_Id := |
7710 | Make_Defining_Identifier (Loc, | |
7711 | Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); | |
70482933 | 7712 | |
df3e68b1 HK |
7713 | -- Generate: |
7714 | -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is | |
7715 | -- begin | |
7716 | -- <stmts> | |
7717 | -- exception -- Finalize and Adjust cases only | |
7718 | -- raise Program_Error; | |
7719 | -- end Deep_Initialize / Adjust / Finalize; | |
70482933 | 7720 | |
df3e68b1 | 7721 | -- or |
70482933 | 7722 | |
df3e68b1 HK |
7723 | -- procedure Finalize_Address (V : System.Address) is |
7724 | -- begin | |
7725 | -- <stmts> | |
7726 | -- end Finalize_Address; | |
70482933 | 7727 | |
df3e68b1 HK |
7728 | Discard_Node ( |
7729 | Make_Subprogram_Body (Loc, | |
7730 | Specification => | |
7731 | Make_Procedure_Specification (Loc, | |
7732 | Defining_Unit_Name => Proc_Id, | |
7733 | Parameter_Specifications => Formals), | |
70482933 | 7734 | |
df3e68b1 | 7735 | Declarations => Empty_List, |
70482933 | 7736 | |
df3e68b1 | 7737 | Handled_Statement_Sequence => |
2c1b72d7 | 7738 | Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); |
70482933 | 7739 | |
1804faa4 AC |
7740 | -- If there are no calls to component initialization, indicate that |
7741 | -- the procedure is trivial, so prevent calls to it. | |
7742 | ||
7743 | if Is_Empty_List (Stmts) | |
7744 | or else Nkind (First (Stmts)) = N_Null_Statement | |
7745 | then | |
7746 | Set_Is_Trivial_Subprogram (Proc_Id); | |
7747 | end if; | |
7748 | ||
df3e68b1 HK |
7749 | return Proc_Id; |
7750 | end Make_Deep_Proc; | |
70482933 | 7751 | |
df3e68b1 HK |
7752 | --------------------------- |
7753 | -- Make_Deep_Record_Body -- | |
7754 | --------------------------- | |
70482933 | 7755 | |
df3e68b1 HK |
7756 | function Make_Deep_Record_Body |
7757 | (Prim : Final_Primitives; | |
7758 | Typ : Entity_Id; | |
7759 | Is_Local : Boolean := False) return List_Id | |
7760 | is | |
7761 | function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; | |
7762 | -- Build the statements necessary to adjust a record type. The type may | |
7763 | -- have discriminants and contain variant parts. Generate: | |
cfae2bed | 7764 | -- |
df3e68b1 | 7765 | -- begin |
df3e68b1 HK |
7766 | -- begin |
7767 | -- [Deep_]Adjust (V.Comp_1); | |
7768 | -- exception | |
7769 | -- when Id : others => | |
7770 | -- if not Raised then | |
7771 | -- Raised := True; | |
7772 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7773 | -- end if; | |
7774 | -- end; | |
7775 | -- . . . | |
7776 | -- begin | |
7777 | -- [Deep_]Adjust (V.Comp_N); | |
7778 | -- exception | |
7779 | -- when Id : others => | |
7780 | -- if not Raised then | |
7781 | -- Raised := True; | |
7782 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7783 | -- end if; | |
7784 | -- end; | |
cfae2bed | 7785 | -- |
df3e68b1 HK |
7786 | -- begin |
7787 | -- Deep_Adjust (V._parent, False); -- If applicable | |
7788 | -- exception | |
7789 | -- when Id : others => | |
7790 | -- if not Raised then | |
7791 | -- Raised := True; | |
7792 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7793 | -- end if; | |
7794 | -- end; | |
cfae2bed | 7795 | -- |
df3e68b1 HK |
7796 | -- if F then |
7797 | -- begin | |
7798 | -- Adjust (V); -- If applicable | |
7799 | -- exception | |
7800 | -- when others => | |
7801 | -- if not Raised then | |
7802 | -- Raised := True; | |
7f37fff1 | 7803 | -- Save_Occurrence (E, Get_Current_Excep.all.all); |
df3e68b1 HK |
7804 | -- end if; |
7805 | -- end; | |
7806 | -- end if; | |
cfae2bed | 7807 | -- |
ca5af305 AC |
7808 | -- if Raised and then not Abort then |
7809 | -- Raise_From_Controlled_Operation (E); | |
df3e68b1 HK |
7810 | -- end if; |
7811 | -- end; | |
7812 | ||
7813 | function Build_Finalize_Statements (Typ : Entity_Id) return List_Id; | |
7814 | -- Build the statements necessary to finalize a record type. The type | |
7815 | -- may have discriminants and contain variant parts. Generate: | |
cfae2bed | 7816 | -- |
df3e68b1 | 7817 | -- declare |
14848f57 | 7818 | -- Abort : constant Boolean := Triggered_By_Abort; |
f9ad6b62 AC |
7819 | -- <or> |
7820 | -- Abort : constant Boolean := False; -- no abort | |
7f37fff1 | 7821 | -- E : Exception_Occurrence; |
df3e68b1 | 7822 | -- Raised : Boolean := False; |
cfae2bed | 7823 | -- |
df3e68b1 | 7824 | -- begin |
df3e68b1 HK |
7825 | -- if F then |
7826 | -- begin | |
7827 | -- Finalize (V); -- If applicable | |
7828 | -- exception | |
7829 | -- when others => | |
7830 | -- if not Raised then | |
7831 | -- Raised := True; | |
7f37fff1 | 7832 | -- Save_Occurrence (E, Get_Current_Excep.all.all); |
df3e68b1 HK |
7833 | -- end if; |
7834 | -- end; | |
7835 | -- end if; | |
cfae2bed | 7836 | -- |
df3e68b1 HK |
7837 | -- case Variant_1 is |
7838 | -- when Value_1 => | |
7839 | -- case State_Counter_N => -- If Is_Local is enabled | |
7840 | -- when N => . | |
7841 | -- goto LN; . | |
7842 | -- ... . | |
7843 | -- when 1 => . | |
7844 | -- goto L1; . | |
7845 | -- when others => . | |
7846 | -- goto L0; . | |
7847 | -- end case; . | |
cfae2bed | 7848 | -- |
df3e68b1 HK |
7849 | -- <<LN>> -- If Is_Local is enabled |
7850 | -- begin | |
7851 | -- [Deep_]Finalize (V.Comp_N); | |
7852 | -- exception | |
7853 | -- when others => | |
7854 | -- if not Raised then | |
7855 | -- Raised := True; | |
7f37fff1 | 7856 | -- Save_Occurrence (E, Get_Current_Excep.all.all); |
df3e68b1 HK |
7857 | -- end if; |
7858 | -- end; | |
7859 | -- . . . | |
7860 | -- <<L1>> | |
7861 | -- begin | |
7862 | -- [Deep_]Finalize (V.Comp_1); | |
7863 | -- exception | |
7864 | -- when others => | |
7865 | -- if not Raised then | |
7866 | -- Raised := True; | |
7f37fff1 | 7867 | -- Save_Occurrence (E, Get_Current_Excep.all.all); |
df3e68b1 HK |
7868 | -- end if; |
7869 | -- end; | |
7870 | -- <<L0>> | |
7871 | -- end case; | |
cfae2bed | 7872 | -- |
df3e68b1 HK |
7873 | -- case State_Counter_1 => -- If Is_Local is enabled |
7874 | -- when M => . | |
7875 | -- goto LM; . | |
7876 | -- ... | |
cfae2bed | 7877 | -- |
df3e68b1 HK |
7878 | -- begin |
7879 | -- Deep_Finalize (V._parent, False); -- If applicable | |
7880 | -- exception | |
7881 | -- when Id : others => | |
7882 | -- if not Raised then | |
7883 | -- Raised := True; | |
7884 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7885 | -- end if; | |
7886 | -- end; | |
cfae2bed | 7887 | -- |
ca5af305 AC |
7888 | -- if Raised and then not Abort then |
7889 | -- Raise_From_Controlled_Operation (E); | |
df3e68b1 HK |
7890 | -- end if; |
7891 | -- end; | |
7892 | ||
7893 | function Parent_Field_Type (Typ : Entity_Id) return Entity_Id; | |
7894 | -- Given a derived tagged type Typ, traverse all components, find field | |
7895 | -- _parent and return its type. | |
7896 | ||
7897 | procedure Preprocess_Components | |
7898 | (Comps : Node_Id; | |
b3143037 | 7899 | Num_Comps : out Nat; |
df3e68b1 HK |
7900 | Has_POC : out Boolean); |
7901 | -- Examine all components in component list Comps, count all controlled | |
7902 | -- components and determine whether at least one of them is per-object | |
7903 | -- constrained. Component _parent is always skipped. | |
7904 | ||
7905 | ----------------------------- | |
7906 | -- Build_Adjust_Statements -- | |
7907 | ----------------------------- | |
7908 | ||
7909 | function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is | |
321c24f7 AC |
7910 | Loc : constant Source_Ptr := Sloc (Typ); |
7911 | Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); | |
7bf911b5 | 7912 | |
321c24f7 | 7913 | Finalizer_Data : Finalization_Exception_Data; |
df3e68b1 | 7914 | |
df3e68b1 HK |
7915 | function Process_Component_List_For_Adjust |
7916 | (Comps : Node_Id) return List_Id; | |
7917 | -- Build all necessary adjust statements for a single component list | |
7918 | ||
7919 | --------------------------------------- | |
7920 | -- Process_Component_List_For_Adjust -- | |
7921 | --------------------------------------- | |
7922 | ||
7923 | function Process_Component_List_For_Adjust | |
7924 | (Comps : Node_Id) return List_Id | |
7925 | is | |
2168d7cc | 7926 | Stmts : constant List_Id := New_List; |
df3e68b1 HK |
7927 | |
7928 | procedure Process_Component_For_Adjust (Decl : Node_Id); | |
7929 | -- Process the declaration of a single controlled component | |
7930 | ||
7931 | ---------------------------------- | |
7932 | -- Process_Component_For_Adjust -- | |
7933 | ---------------------------------- | |
7934 | ||
7935 | procedure Process_Component_For_Adjust (Decl : Node_Id) is | |
2168d7cc AC |
7936 | Id : constant Entity_Id := Defining_Identifier (Decl); |
7937 | Typ : constant Entity_Id := Etype (Id); | |
7938 | ||
7939 | Adj_Call : Node_Id; | |
70482933 | 7940 | |
df3e68b1 | 7941 | begin |
7bf911b5 | 7942 | -- begin |
df3e68b1 | 7943 | -- [Deep_]Adjust (V.Id); |
7bf911b5 | 7944 | |
df3e68b1 HK |
7945 | -- exception |
7946 | -- when others => | |
7947 | -- if not Raised then | |
7948 | -- Raised := True; | |
7949 | -- Save_Occurrence (E, Get_Current_Excep.all.all); | |
7950 | -- end if; | |
7951 | -- end; | |
7952 | ||
2168d7cc | 7953 | Adj_Call := |
df3e68b1 HK |
7954 | Make_Adjust_Call ( |
7955 | Obj_Ref => | |
7956 | Make_Selected_Component (Loc, | |
cfae2bed AC |
7957 | Prefix => Make_Identifier (Loc, Name_V), |
7958 | Selector_Name => Make_Identifier (Loc, Chars (Id))), | |
7959 | Typ => Typ); | |
df3e68b1 | 7960 | |
2168d7cc AC |
7961 | -- Guard against a missing [Deep_]Adjust when the component |
7962 | -- type was not properly frozen. | |
7963 | ||
7964 | if Present (Adj_Call) then | |
7965 | if Exceptions_OK then | |
7966 | Adj_Call := | |
7967 | Make_Block_Statement (Loc, | |
7968 | Handled_Statement_Sequence => | |
7969 | Make_Handled_Sequence_Of_Statements (Loc, | |
7970 | Statements => New_List (Adj_Call), | |
7971 | Exception_Handlers => New_List ( | |
7972 | Build_Exception_Handler (Finalizer_Data)))); | |
7973 | end if; | |
70482933 | 7974 | |
2168d7cc AC |
7975 | Append_To (Stmts, Adj_Call); |
7976 | end if; | |
df3e68b1 | 7977 | end Process_Component_For_Adjust; |
70482933 | 7978 | |
2168d7cc AC |
7979 | -- Local variables |
7980 | ||
7981 | Decl : Node_Id; | |
7982 | Decl_Id : Entity_Id; | |
7983 | Decl_Typ : Entity_Id; | |
7984 | Has_POC : Boolean; | |
7985 | Num_Comps : Nat; | |
321c24f7 | 7986 | Var_Case : Node_Id; |
2168d7cc | 7987 | |
df3e68b1 | 7988 | -- Start of processing for Process_Component_List_For_Adjust |
70482933 | 7989 | |
df3e68b1 HK |
7990 | begin |
7991 | -- Perform an initial check, determine the number of controlled | |
7992 | -- components in the current list and whether at least one of them | |
7993 | -- is per-object constrained. | |
70482933 | 7994 | |
df3e68b1 | 7995 | Preprocess_Components (Comps, Num_Comps, Has_POC); |
70482933 | 7996 | |
df3e68b1 HK |
7997 | -- The processing in this routine is done in the following order: |
7998 | -- 1) Regular components | |
7999 | -- 2) Per-object constrained components | |
8000 | -- 3) Variant parts | |
70482933 | 8001 | |
df3e68b1 | 8002 | if Num_Comps > 0 then |
70482933 | 8003 | |
df3e68b1 | 8004 | -- Process all regular components in order of declarations |
70482933 | 8005 | |
df3e68b1 HK |
8006 | Decl := First_Non_Pragma (Component_Items (Comps)); |
8007 | while Present (Decl) loop | |
8008 | Decl_Id := Defining_Identifier (Decl); | |
8009 | Decl_Typ := Etype (Decl_Id); | |
70482933 | 8010 | |
df3e68b1 | 8011 | -- Skip _parent as well as per-object constrained components |
70482933 | 8012 | |
df3e68b1 HK |
8013 | if Chars (Decl_Id) /= Name_uParent |
8014 | and then Needs_Finalization (Decl_Typ) | |
8015 | then | |
8016 | if Has_Access_Constraint (Decl_Id) | |
8017 | and then No (Expression (Decl)) | |
8018 | then | |
8019 | null; | |
8020 | else | |
8021 | Process_Component_For_Adjust (Decl); | |
8022 | end if; | |
8023 | end if; | |
70482933 | 8024 | |
df3e68b1 HK |
8025 | Next_Non_Pragma (Decl); |
8026 | end loop; | |
70482933 | 8027 | |
df3e68b1 HK |
8028 | -- Process all per-object constrained components in order of |
8029 | -- declarations. | |
70482933 | 8030 | |
df3e68b1 HK |
8031 | if Has_POC then |
8032 | Decl := First_Non_Pragma (Component_Items (Comps)); | |
8033 | while Present (Decl) loop | |
8034 | Decl_Id := Defining_Identifier (Decl); | |
8035 | Decl_Typ := Etype (Decl_Id); | |
70482933 | 8036 | |
df3e68b1 | 8037 | -- Skip _parent |
70482933 | 8038 | |
df3e68b1 HK |
8039 | if Chars (Decl_Id) /= Name_uParent |
8040 | and then Needs_Finalization (Decl_Typ) | |
8041 | and then Has_Access_Constraint (Decl_Id) | |
8042 | and then No (Expression (Decl)) | |
8043 | then | |
8044 | Process_Component_For_Adjust (Decl); | |
8045 | end if; | |
70482933 | 8046 | |
df3e68b1 HK |
8047 | Next_Non_Pragma (Decl); |
8048 | end loop; | |
8049 | end if; | |
70482933 RK |
8050 | end if; |
8051 | ||
df3e68b1 | 8052 | -- Process all variants, if any |
70482933 | 8053 | |
df3e68b1 HK |
8054 | Var_Case := Empty; |
8055 | if Present (Variant_Part (Comps)) then | |
8056 | declare | |
8057 | Var_Alts : constant List_Id := New_List; | |
8058 | Var : Node_Id; | |
70482933 | 8059 | |
df3e68b1 HK |
8060 | begin |
8061 | Var := First_Non_Pragma (Variants (Variant_Part (Comps))); | |
8062 | while Present (Var) loop | |
8063 | ||
8064 | -- Generate: | |
8065 | -- when <discrete choices> => | |
8066 | -- <adjust statements> | |
8067 | ||
8068 | Append_To (Var_Alts, | |
8069 | Make_Case_Statement_Alternative (Loc, | |
8070 | Discrete_Choices => | |
8071 | New_Copy_List (Discrete_Choices (Var)), | |
2c1b72d7 | 8072 | Statements => |
df3e68b1 HK |
8073 | Process_Component_List_For_Adjust ( |
8074 | Component_List (Var)))); | |
8075 | ||
8076 | Next_Non_Pragma (Var); | |
8077 | end loop; | |
8078 | ||
8079 | -- Generate: | |
8080 | -- case V.<discriminant> is | |
8081 | -- when <discrete choices 1> => | |
8082 | -- <adjust statements 1> | |
8083 | -- ... | |
8084 | -- when <discrete choices N> => | |
8085 | -- <adjust statements N> | |
8086 | -- end case; | |
8087 | ||
8088 | Var_Case := | |
8089 | Make_Case_Statement (Loc, | |
8090 | Expression => | |
8091 | Make_Selected_Component (Loc, | |
2c1b72d7 | 8092 | Prefix => Make_Identifier (Loc, Name_V), |
df3e68b1 HK |
8093 | Selector_Name => |
8094 | Make_Identifier (Loc, | |
2c1b72d7 | 8095 | Chars => Chars (Name (Variant_Part (Comps))))), |
df3e68b1 HK |
8096 | Alternatives => Var_Alts); |
8097 | end; | |
8098 | end if; | |
70482933 | 8099 | |
df3e68b1 | 8100 | -- Add the variant case statement to the list of statements |
70482933 | 8101 | |
df3e68b1 HK |
8102 | if Present (Var_Case) then |
8103 | Append_To (Stmts, Var_Case); | |
8104 | end if; | |
70482933 | 8105 | |
df3e68b1 HK |
8106 | -- If the component list did not have any controlled components |
8107 | -- nor variants, return null. | |
c364d9be | 8108 | |
df3e68b1 HK |
8109 | if Is_Empty_List (Stmts) then |
8110 | Append_To (Stmts, Make_Null_Statement (Loc)); | |
8111 | end if; | |
c364d9be | 8112 | |
df3e68b1 HK |
8113 | return Stmts; |
8114 | end Process_Component_List_For_Adjust; | |
70482933 | 8115 | |
321c24f7 AC |
8116 | -- Local variables |
8117 | ||
a6d25cad | 8118 | Bod_Stmts : List_Id := No_List; |
321c24f7 AC |
8119 | Finalizer_Decls : List_Id := No_List; |
8120 | Rec_Def : Node_Id; | |
8121 | ||
df3e68b1 | 8122 | -- Start of processing for Build_Adjust_Statements |
70482933 | 8123 | |
df3e68b1 | 8124 | begin |
2d1debf8 AC |
8125 | Finalizer_Decls := New_List; |
8126 | Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); | |
70482933 | 8127 | |
df3e68b1 HK |
8128 | if Nkind (Typ_Def) = N_Derived_Type_Definition then |
8129 | Rec_Def := Record_Extension_Part (Typ_Def); | |
8130 | else | |
8131 | Rec_Def := Typ_Def; | |
8132 | end if; | |
70482933 | 8133 | |
df3e68b1 | 8134 | -- Create an adjust sequence for all record components |
c364d9be | 8135 | |
df3e68b1 HK |
8136 | if Present (Component_List (Rec_Def)) then |
8137 | Bod_Stmts := | |
8138 | Process_Component_List_For_Adjust (Component_List (Rec_Def)); | |
8139 | end if; | |
8a7988f5 | 8140 | |
df3e68b1 HK |
8141 | -- A derived record type must adjust all inherited components. This |
8142 | -- action poses the following problem: | |
886b5a18 | 8143 | |
df3e68b1 HK |
8144 | -- procedure Deep_Adjust (Obj : in out Parent_Typ) is |
8145 | -- begin | |
8146 | -- Adjust (Obj); | |
8147 | -- ... | |
886b5a18 | 8148 | |
df3e68b1 HK |
8149 | -- procedure Deep_Adjust (Obj : in out Derived_Typ) is |
8150 | -- begin | |
8151 | -- Deep_Adjust (Obj._parent); | |
8152 | -- ... | |
8153 | -- Adjust (Obj); | |
8154 | -- ... | |
886b5a18 | 8155 | |
df3e68b1 HK |
8156 | -- Adjusting the derived type will invoke Adjust of the parent and |
8157 | -- then that of the derived type. This is undesirable because both | |
8158 | -- routines may modify shared components. Only the Adjust of the | |
8159 | -- derived type should be invoked. | |
886b5a18 | 8160 | |
df3e68b1 HK |
8161 | -- To prevent this double adjustment of shared components, |
8162 | -- Deep_Adjust uses a flag to control the invocation of Adjust: | |
886b5a18 | 8163 | |
df3e68b1 HK |
8164 | -- procedure Deep_Adjust |
8165 | -- (Obj : in out Some_Type; | |
8166 | -- Flag : Boolean := True) | |
8167 | -- is | |
8168 | -- begin | |
8169 | -- if Flag then | |
8170 | -- Adjust (Obj); | |
8171 | -- end if; | |
8172 | -- ... | |
886b5a18 | 8173 | |
df3e68b1 HK |
8174 | -- When Deep_Adjust is invokes for field _parent, a value of False is |
8175 | -- provided for the flag: | |
886b5a18 | 8176 | |
df3e68b1 HK |
8177 | -- Deep_Adjust (Obj._parent, False); |
8178 | ||
cfae2bed | 8179 | if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then |
df3e68b1 HK |
8180 | declare |
8181 | Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); | |
8182 | Adj_Stmt : Node_Id; | |
8183 | Call : Node_Id; | |
c364d9be | 8184 | |
df3e68b1 HK |
8185 | begin |
8186 | if Needs_Finalization (Par_Typ) then | |
8187 | Call := | |
2c1b72d7 | 8188 | Make_Adjust_Call |
4ac2bbbd | 8189 | (Obj_Ref => |
2c1b72d7 AC |
8190 | Make_Selected_Component (Loc, |
8191 | Prefix => Make_Identifier (Loc, Name_V), | |
8192 | Selector_Name => | |
8193 | Make_Identifier (Loc, Name_uParent)), | |
4ac2bbbd AC |
8194 | Typ => Par_Typ, |
8195 | Skip_Self => True); | |
df3e68b1 HK |
8196 | |
8197 | -- Generate: | |
7bf911b5 | 8198 | -- begin |
df3e68b1 | 8199 | -- Deep_Adjust (V._parent, False); |
7bf911b5 | 8200 | |
df3e68b1 HK |
8201 | -- exception |
8202 | -- when Id : others => | |
8203 | -- if not Raised then | |
8204 | -- Raised := True; | |
8205 | -- Save_Occurrence (E, | |
8206 | -- Get_Current_Excep.all.all); | |
8207 | -- end if; | |
8208 | -- end; | |
8209 | ||
8210 | if Present (Call) then | |
8211 | Adj_Stmt := Call; | |
8212 | ||
8213 | if Exceptions_OK then | |
8214 | Adj_Stmt := | |
8215 | Make_Block_Statement (Loc, | |
8216 | Handled_Statement_Sequence => | |
8217 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 8218 | Statements => New_List (Adj_Stmt), |
df3e68b1 | 8219 | Exception_Handlers => New_List ( |
886b5a18 | 8220 | Build_Exception_Handler (Finalizer_Data)))); |
df3e68b1 | 8221 | end if; |
70482933 | 8222 | |
df3e68b1 HK |
8223 | Prepend_To (Bod_Stmts, Adj_Stmt); |
8224 | end if; | |
8225 | end if; | |
8226 | end; | |
70482933 RK |
8227 | end if; |
8228 | ||
df3e68b1 HK |
8229 | -- Adjust the object. This action must be performed last after all |
8230 | -- components have been adjusted. | |
8231 | ||
8232 | if Is_Controlled (Typ) then | |
8233 | declare | |
8234 | Adj_Stmt : Node_Id; | |
8235 | Proc : Entity_Id; | |
8a7988f5 | 8236 | |
df3e68b1 | 8237 | begin |
ca811241 | 8238 | Proc := Find_Optional_Prim_Op (Typ, Name_Adjust); |
df3e68b1 HK |
8239 | |
8240 | -- Generate: | |
8241 | -- if F then | |
7bf911b5 | 8242 | -- begin |
df3e68b1 | 8243 | -- Adjust (V); |
7bf911b5 | 8244 | |
df3e68b1 HK |
8245 | -- exception |
8246 | -- when others => | |
8247 | -- if not Raised then | |
8248 | -- Raised := True; | |
8249 | -- Save_Occurrence (E, | |
8250 | -- Get_Current_Excep.all.all); | |
8251 | -- end if; | |
8252 | -- end; | |
8253 | -- end if; | |
8254 | ||
8255 | if Present (Proc) then | |
8256 | Adj_Stmt := | |
8257 | Make_Procedure_Call_Statement (Loc, | |
e4494292 | 8258 | Name => New_Occurrence_Of (Proc, Loc), |
df3e68b1 HK |
8259 | Parameter_Associations => New_List ( |
8260 | Make_Identifier (Loc, Name_V))); | |
8261 | ||
8262 | if Exceptions_OK then | |
8263 | Adj_Stmt := | |
8264 | Make_Block_Statement (Loc, | |
8265 | Handled_Statement_Sequence => | |
8266 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 8267 | Statements => New_List (Adj_Stmt), |
df3e68b1 HK |
8268 | Exception_Handlers => New_List ( |
8269 | Build_Exception_Handler | |
36b8f95f | 8270 | (Finalizer_Data)))); |
df3e68b1 | 8271 | end if; |
70482933 | 8272 | |
df3e68b1 HK |
8273 | Append_To (Bod_Stmts, |
8274 | Make_If_Statement (Loc, | |
2c1b72d7 | 8275 | Condition => Make_Identifier (Loc, Name_F), |
df3e68b1 HK |
8276 | Then_Statements => New_List (Adj_Stmt))); |
8277 | end if; | |
8278 | end; | |
70482933 RK |
8279 | end if; |
8280 | ||
df3e68b1 HK |
8281 | -- At this point either all adjustment statements have been generated |
8282 | -- or the type is not controlled. | |
70482933 | 8283 | |
df3e68b1 HK |
8284 | if Is_Empty_List (Bod_Stmts) then |
8285 | Append_To (Bod_Stmts, Make_Null_Statement (Loc)); | |
70482933 | 8286 | |
df3e68b1 | 8287 | return Bod_Stmts; |
70482933 | 8288 | |
df3e68b1 HK |
8289 | -- Generate: |
8290 | -- declare | |
14848f57 | 8291 | -- Abort : constant Boolean := Triggered_By_Abort; |
f9ad6b62 AC |
8292 | -- <or> |
8293 | -- Abort : constant Boolean := False; -- no abort | |
8294 | ||
7f37fff1 | 8295 | -- E : Exception_Occurrence; |
df3e68b1 | 8296 | -- Raised : Boolean := False; |
70482933 | 8297 | |
df3e68b1 | 8298 | -- begin |
df3e68b1 | 8299 | -- <adjust statements> |
70482933 | 8300 | |
ca5af305 AC |
8301 | -- if Raised and then not Abort then |
8302 | -- Raise_From_Controlled_Operation (E); | |
df3e68b1 HK |
8303 | -- end if; |
8304 | -- end; | |
70482933 | 8305 | |
df3e68b1 HK |
8306 | else |
8307 | if Exceptions_OK then | |
7bf911b5 | 8308 | Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); |
df3e68b1 | 8309 | end if; |
70482933 | 8310 | |
df3e68b1 HK |
8311 | return |
8312 | New_List ( | |
8313 | Make_Block_Statement (Loc, | |
2c1b72d7 | 8314 | Declarations => |
36b8f95f | 8315 | Finalizer_Decls, |
df3e68b1 | 8316 | Handled_Statement_Sequence => |
2c1b72d7 | 8317 | Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); |
df3e68b1 HK |
8318 | end if; |
8319 | end Build_Adjust_Statements; | |
8320 | ||
8321 | ------------------------------- | |
8322 | -- Build_Finalize_Statements -- | |
8323 | ------------------------------- | |
8324 | ||
8325 | function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is | |
321c24f7 AC |
8326 | Loc : constant Source_Ptr := Sloc (Typ); |
8327 | Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); | |
7bf911b5 | 8328 | |
02248717 | 8329 | Counter : Nat := 0; |
321c24f7 | 8330 | Finalizer_Data : Finalization_Exception_Data; |
df3e68b1 | 8331 | |
df3e68b1 HK |
8332 | function Process_Component_List_For_Finalize |
8333 | (Comps : Node_Id) return List_Id; | |
8334 | -- Build all necessary finalization statements for a single component | |
8335 | -- list. The statements may include a jump circuitry if flag Is_Local | |
8336 | -- is enabled. | |
8337 | ||
8338 | ----------------------------------------- | |
8339 | -- Process_Component_List_For_Finalize -- | |
8340 | ----------------------------------------- | |
8341 | ||
8342 | function Process_Component_List_For_Finalize | |
8343 | (Comps : Node_Id) return List_Id | |
8344 | is | |
df3e68b1 | 8345 | procedure Process_Component_For_Finalize |
7e6060af AC |
8346 | (Decl : Node_Id; |
8347 | Alts : List_Id; | |
8348 | Decls : List_Id; | |
8349 | Stmts : List_Id; | |
8350 | Num_Comps : in out Nat); | |
df3e68b1 HK |
8351 | -- Process the declaration of a single controlled component. If |
8352 | -- flag Is_Local is enabled, create the corresponding label and | |
8353 | -- jump circuitry. Alts is the list of case alternatives, Decls | |
8354 | -- is the top level declaration list where labels are declared | |
7e6060af AC |
8355 | -- and Stmts is the list of finalization actions. Num_Comps |
8356 | -- denotes the current number of components needing finalization. | |
df3e68b1 HK |
8357 | |
8358 | ------------------------------------ | |
8359 | -- Process_Component_For_Finalize -- | |
8360 | ------------------------------------ | |
8361 | ||
8362 | procedure Process_Component_For_Finalize | |
7e6060af AC |
8363 | (Decl : Node_Id; |
8364 | Alts : List_Id; | |
8365 | Decls : List_Id; | |
8366 | Stmts : List_Id; | |
8367 | Num_Comps : in out Nat) | |
df3e68b1 HK |
8368 | is |
8369 | Id : constant Entity_Id := Defining_Identifier (Decl); | |
8370 | Typ : constant Entity_Id := Etype (Id); | |
2168d7cc | 8371 | Fin_Call : Node_Id; |
70482933 | 8372 | |
df3e68b1 HK |
8373 | begin |
8374 | if Is_Local then | |
8375 | declare | |
8376 | Label : Node_Id; | |
8377 | Label_Id : Entity_Id; | |
8378 | ||
8379 | begin | |
8380 | -- Generate: | |
8381 | -- LN : label; | |
8382 | ||
8383 | Label_Id := | |
8384 | Make_Identifier (Loc, | |
8385 | Chars => New_External_Name ('L', Num_Comps)); | |
8386 | Set_Entity (Label_Id, | |
8387 | Make_Defining_Identifier (Loc, Chars (Label_Id))); | |
8388 | Label := Make_Label (Loc, Label_Id); | |
8389 | ||
8390 | Append_To (Decls, | |
8391 | Make_Implicit_Label_Declaration (Loc, | |
8392 | Defining_Identifier => Entity (Label_Id), | |
2c1b72d7 | 8393 | Label_Construct => Label)); |
df3e68b1 HK |
8394 | |
8395 | -- Generate: | |
8396 | -- when N => | |
8397 | -- goto LN; | |
8398 | ||
8399 | Append_To (Alts, | |
8400 | Make_Case_Statement_Alternative (Loc, | |
8401 | Discrete_Choices => New_List ( | |
8402 | Make_Integer_Literal (Loc, Num_Comps)), | |
8403 | ||
8404 | Statements => New_List ( | |
8405 | Make_Goto_Statement (Loc, | |
8406 | Name => | |
e4494292 | 8407 | New_Occurrence_Of (Entity (Label_Id), Loc))))); |
df3e68b1 HK |
8408 | |
8409 | -- Generate: | |
8410 | -- <<LN>> | |
8411 | ||
8412 | Append_To (Stmts, Label); | |
8413 | ||
8414 | -- Decrease the number of components to be processed. | |
8415 | -- This action yields a new Label_Id in future calls. | |
8416 | ||
8417 | Num_Comps := Num_Comps - 1; | |
8418 | end; | |
8419 | end if; | |
70482933 | 8420 | |
df3e68b1 HK |
8421 | -- Generate: |
8422 | -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation | |
8423 | ||
8424 | -- begin -- Exception handlers allowed | |
8425 | -- [Deep_]Finalize (V.Id); | |
8426 | -- exception | |
8427 | -- when others => | |
8428 | -- if not Raised then | |
8429 | -- Raised := True; | |
8430 | -- Save_Occurrence (E, | |
8431 | -- Get_Current_Excep.all.all); | |
8432 | -- end if; | |
8433 | -- end; | |
8434 | ||
2168d7cc | 8435 | Fin_Call := |
2c1b72d7 AC |
8436 | Make_Final_Call |
8437 | (Obj_Ref => | |
8438 | Make_Selected_Component (Loc, | |
8439 | Prefix => Make_Identifier (Loc, Name_V), | |
8440 | Selector_Name => Make_Identifier (Loc, Chars (Id))), | |
8441 | Typ => Typ); | |
df3e68b1 | 8442 | |
2168d7cc AC |
8443 | -- Guard against a missing [Deep_]Finalize when the component |
8444 | -- type was not properly frozen. | |
8445 | ||
8446 | if Present (Fin_Call) then | |
8447 | if Exceptions_OK then | |
8448 | Fin_Call := | |
8449 | Make_Block_Statement (Loc, | |
8450 | Handled_Statement_Sequence => | |
8451 | Make_Handled_Sequence_Of_Statements (Loc, | |
8452 | Statements => New_List (Fin_Call), | |
8453 | Exception_Handlers => New_List ( | |
8454 | Build_Exception_Handler (Finalizer_Data)))); | |
8455 | end if; | |
70482933 | 8456 | |
2168d7cc AC |
8457 | Append_To (Stmts, Fin_Call); |
8458 | end if; | |
df3e68b1 | 8459 | end Process_Component_For_Finalize; |
70482933 | 8460 | |
321c24f7 AC |
8461 | -- Local variables |
8462 | ||
8463 | Alts : List_Id; | |
a6d25cad | 8464 | Counter_Id : Entity_Id := Empty; |
321c24f7 AC |
8465 | Decl : Node_Id; |
8466 | Decl_Id : Entity_Id; | |
8467 | Decl_Typ : Entity_Id; | |
8468 | Decls : List_Id; | |
8469 | Has_POC : Boolean; | |
8470 | Jump_Block : Node_Id; | |
8471 | Label : Node_Id; | |
8472 | Label_Id : Entity_Id; | |
7e6060af | 8473 | Num_Comps : Nat; |
321c24f7 AC |
8474 | Stmts : List_Id; |
8475 | Var_Case : Node_Id; | |
8476 | ||
df3e68b1 | 8477 | -- Start of processing for Process_Component_List_For_Finalize |
70482933 | 8478 | |
df3e68b1 HK |
8479 | begin |
8480 | -- Perform an initial check, look for controlled and per-object | |
8481 | -- constrained components. | |
70482933 | 8482 | |
df3e68b1 | 8483 | Preprocess_Components (Comps, Num_Comps, Has_POC); |
70482933 | 8484 | |
df3e68b1 HK |
8485 | -- Create a state counter to service the current component list. |
8486 | -- This step is performed before the variants are inspected in | |
8487 | -- order to generate the same state counter names as those from | |
8488 | -- Build_Initialize_Statements. | |
70482933 | 8489 | |
36295779 | 8490 | if Num_Comps > 0 and then Is_Local then |
df3e68b1 | 8491 | Counter := Counter + 1; |
70482933 | 8492 | |
df3e68b1 HK |
8493 | Counter_Id := |
8494 | Make_Defining_Identifier (Loc, | |
8495 | Chars => New_External_Name ('C', Counter)); | |
8496 | end if; | |
70482933 | 8497 | |
df3e68b1 HK |
8498 | -- Process the component in the following order: |
8499 | -- 1) Variants | |
8500 | -- 2) Per-object constrained components | |
8501 | -- 3) Regular components | |
70482933 | 8502 | |
df3e68b1 | 8503 | -- Start with the variant parts |
70482933 | 8504 | |
df3e68b1 HK |
8505 | Var_Case := Empty; |
8506 | if Present (Variant_Part (Comps)) then | |
8507 | declare | |
8508 | Var_Alts : constant List_Id := New_List; | |
8509 | Var : Node_Id; | |
70482933 | 8510 | |
df3e68b1 HK |
8511 | begin |
8512 | Var := First_Non_Pragma (Variants (Variant_Part (Comps))); | |
8513 | while Present (Var) loop | |
8514 | ||
8515 | -- Generate: | |
8516 | -- when <discrete choices> => | |
8517 | -- <finalize statements> | |
8518 | ||
8519 | Append_To (Var_Alts, | |
8520 | Make_Case_Statement_Alternative (Loc, | |
8521 | Discrete_Choices => | |
8522 | New_Copy_List (Discrete_Choices (Var)), | |
8523 | Statements => | |
8524 | Process_Component_List_For_Finalize ( | |
8525 | Component_List (Var)))); | |
8526 | ||
8527 | Next_Non_Pragma (Var); | |
8528 | end loop; | |
8529 | ||
8530 | -- Generate: | |
8531 | -- case V.<discriminant> is | |
8532 | -- when <discrete choices 1> => | |
8533 | -- <finalize statements 1> | |
8534 | -- ... | |
8535 | -- when <discrete choices N> => | |
8536 | -- <finalize statements N> | |
8537 | -- end case; | |
8538 | ||
8539 | Var_Case := | |
8540 | Make_Case_Statement (Loc, | |
8541 | Expression => | |
8542 | Make_Selected_Component (Loc, | |
cfae2bed | 8543 | Prefix => Make_Identifier (Loc, Name_V), |
df3e68b1 HK |
8544 | Selector_Name => |
8545 | Make_Identifier (Loc, | |
cfae2bed | 8546 | Chars => Chars (Name (Variant_Part (Comps))))), |
df3e68b1 HK |
8547 | Alternatives => Var_Alts); |
8548 | end; | |
8549 | end if; | |
70482933 | 8550 | |
df3e68b1 HK |
8551 | -- The current component list does not have a single controlled |
8552 | -- component, however it may contain variants. Return the case | |
8553 | -- statement for the variants or nothing. | |
70482933 | 8554 | |
df3e68b1 HK |
8555 | if Num_Comps = 0 then |
8556 | if Present (Var_Case) then | |
8557 | return New_List (Var_Case); | |
8558 | else | |
8559 | return New_List (Make_Null_Statement (Loc)); | |
8560 | end if; | |
8561 | end if; | |
70482933 | 8562 | |
df3e68b1 | 8563 | -- Prepare all lists |
70482933 | 8564 | |
df3e68b1 HK |
8565 | Alts := New_List; |
8566 | Decls := New_List; | |
8567 | Stmts := New_List; | |
dcfa065d | 8568 | |
df3e68b1 | 8569 | -- Process all per-object constrained components in reverse order |
70482933 | 8570 | |
df3e68b1 HK |
8571 | if Has_POC then |
8572 | Decl := Last_Non_Pragma (Component_Items (Comps)); | |
8573 | while Present (Decl) loop | |
8574 | Decl_Id := Defining_Identifier (Decl); | |
8575 | Decl_Typ := Etype (Decl_Id); | |
70482933 | 8576 | |
df3e68b1 | 8577 | -- Skip _parent |
70482933 | 8578 | |
df3e68b1 HK |
8579 | if Chars (Decl_Id) /= Name_uParent |
8580 | and then Needs_Finalization (Decl_Typ) | |
8581 | and then Has_Access_Constraint (Decl_Id) | |
8582 | and then No (Expression (Decl)) | |
8583 | then | |
7e6060af AC |
8584 | Process_Component_For_Finalize |
8585 | (Decl, Alts, Decls, Stmts, Num_Comps); | |
df3e68b1 | 8586 | end if; |
70482933 | 8587 | |
df3e68b1 HK |
8588 | Prev_Non_Pragma (Decl); |
8589 | end loop; | |
8590 | end if; | |
70482933 | 8591 | |
df3e68b1 | 8592 | -- Process the rest of the components in reverse order |
70482933 | 8593 | |
df3e68b1 HK |
8594 | Decl := Last_Non_Pragma (Component_Items (Comps)); |
8595 | while Present (Decl) loop | |
8596 | Decl_Id := Defining_Identifier (Decl); | |
8597 | Decl_Typ := Etype (Decl_Id); | |
70482933 | 8598 | |
df3e68b1 | 8599 | -- Skip _parent |
70482933 | 8600 | |
df3e68b1 HK |
8601 | if Chars (Decl_Id) /= Name_uParent |
8602 | and then Needs_Finalization (Decl_Typ) | |
8603 | then | |
8604 | -- Skip per-object constrained components since they were | |
8605 | -- handled in the above step. | |
70482933 | 8606 | |
df3e68b1 HK |
8607 | if Has_Access_Constraint (Decl_Id) |
8608 | and then No (Expression (Decl)) | |
8609 | then | |
8610 | null; | |
8611 | else | |
7e6060af AC |
8612 | Process_Component_For_Finalize |
8613 | (Decl, Alts, Decls, Stmts, Num_Comps); | |
df3e68b1 HK |
8614 | end if; |
8615 | end if; | |
70482933 | 8616 | |
df3e68b1 HK |
8617 | Prev_Non_Pragma (Decl); |
8618 | end loop; | |
70482933 | 8619 | |
df3e68b1 HK |
8620 | -- Generate: |
8621 | -- declare | |
8622 | -- LN : label; -- If Is_Local is enabled | |
8623 | -- ... . | |
8624 | -- L0 : label; . | |
8625 | ||
8626 | -- begin . | |
8627 | -- case CounterX is . | |
8628 | -- when N => . | |
8629 | -- goto LN; . | |
8630 | -- ... . | |
8631 | -- when 1 => . | |
8632 | -- goto L1; . | |
8633 | -- when others => . | |
8634 | -- goto L0; . | |
8635 | -- end case; . | |
8636 | ||
8637 | -- <<LN>> -- If Is_Local is enabled | |
8638 | -- begin | |
8639 | -- [Deep_]Finalize (V.CompY); | |
8640 | -- exception | |
8641 | -- when Id : others => | |
8642 | -- if not Raised then | |
8643 | -- Raised := True; | |
8644 | -- Save_Occurrence (E, | |
8645 | -- Get_Current_Excep.all.all); | |
8646 | -- end if; | |
8647 | -- end; | |
8648 | -- ... | |
8649 | -- <<L0>> -- If Is_Local is enabled | |
8650 | -- end; | |
8651 | ||
8652 | if Is_Local then | |
8653 | ||
8654 | -- Add the declaration of default jump location L0, its | |
8655 | -- corresponding alternative and its place in the statements. | |
8656 | ||
cfae2bed | 8657 | Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0)); |
df3e68b1 HK |
8658 | Set_Entity (Label_Id, |
8659 | Make_Defining_Identifier (Loc, Chars (Label_Id))); | |
8660 | Label := Make_Label (Loc, Label_Id); | |
8661 | ||
8662 | Append_To (Decls, -- declaration | |
8663 | Make_Implicit_Label_Declaration (Loc, | |
8664 | Defining_Identifier => Entity (Label_Id), | |
cfae2bed | 8665 | Label_Construct => Label)); |
df3e68b1 HK |
8666 | |
8667 | Append_To (Alts, -- alternative | |
8668 | Make_Case_Statement_Alternative (Loc, | |
8669 | Discrete_Choices => New_List ( | |
8670 | Make_Others_Choice (Loc)), | |
8671 | ||
8672 | Statements => New_List ( | |
8673 | Make_Goto_Statement (Loc, | |
e4494292 | 8674 | Name => New_Occurrence_Of (Entity (Label_Id), Loc))))); |
df3e68b1 HK |
8675 | |
8676 | Append_To (Stmts, Label); -- statement | |
8677 | ||
8678 | -- Create the jump block | |
8679 | ||
8680 | Prepend_To (Stmts, | |
8681 | Make_Case_Statement (Loc, | |
cfae2bed | 8682 | Expression => Make_Identifier (Loc, Chars (Counter_Id)), |
df3e68b1 HK |
8683 | Alternatives => Alts)); |
8684 | end if; | |
70482933 | 8685 | |
df3e68b1 HK |
8686 | Jump_Block := |
8687 | Make_Block_Statement (Loc, | |
2c1b72d7 | 8688 | Declarations => Decls, |
df3e68b1 | 8689 | Handled_Statement_Sequence => |
2c1b72d7 | 8690 | Make_Handled_Sequence_Of_Statements (Loc, Stmts)); |
70482933 | 8691 | |
df3e68b1 HK |
8692 | if Present (Var_Case) then |
8693 | return New_List (Var_Case, Jump_Block); | |
8694 | else | |
8695 | return New_List (Jump_Block); | |
8696 | end if; | |
8697 | end Process_Component_List_For_Finalize; | |
70482933 | 8698 | |
321c24f7 AC |
8699 | -- Local variables |
8700 | ||
a6d25cad | 8701 | Bod_Stmts : List_Id := No_List; |
321c24f7 AC |
8702 | Finalizer_Decls : List_Id := No_List; |
8703 | Rec_Def : Node_Id; | |
8704 | ||
df3e68b1 | 8705 | -- Start of processing for Build_Finalize_Statements |
70482933 RK |
8706 | |
8707 | begin | |
2d1debf8 AC |
8708 | Finalizer_Decls := New_List; |
8709 | Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); | |
70482933 | 8710 | |
df3e68b1 HK |
8711 | if Nkind (Typ_Def) = N_Derived_Type_Definition then |
8712 | Rec_Def := Record_Extension_Part (Typ_Def); | |
8713 | else | |
8714 | Rec_Def := Typ_Def; | |
8715 | end if; | |
70482933 | 8716 | |
df3e68b1 | 8717 | -- Create a finalization sequence for all record components |
70482933 | 8718 | |
df3e68b1 HK |
8719 | if Present (Component_List (Rec_Def)) then |
8720 | Bod_Stmts := | |
8721 | Process_Component_List_For_Finalize (Component_List (Rec_Def)); | |
8722 | end if; | |
70482933 | 8723 | |
df3e68b1 HK |
8724 | -- A derived record type must finalize all inherited components. This |
8725 | -- action poses the following problem: | |
886b5a18 | 8726 | |
df3e68b1 HK |
8727 | -- procedure Deep_Finalize (Obj : in out Parent_Typ) is |
8728 | -- begin | |
8729 | -- Finalize (Obj); | |
8730 | -- ... | |
886b5a18 | 8731 | |
df3e68b1 HK |
8732 | -- procedure Deep_Finalize (Obj : in out Derived_Typ) is |
8733 | -- begin | |
8734 | -- Deep_Finalize (Obj._parent); | |
8735 | -- ... | |
8736 | -- Finalize (Obj); | |
8737 | -- ... | |
886b5a18 | 8738 | |
df3e68b1 HK |
8739 | -- Finalizing the derived type will invoke Finalize of the parent and |
8740 | -- then that of the derived type. This is undesirable because both | |
8741 | -- routines may modify shared components. Only the Finalize of the | |
8742 | -- derived type should be invoked. | |
886b5a18 | 8743 | |
df3e68b1 HK |
8744 | -- To prevent this double adjustment of shared components, |
8745 | -- Deep_Finalize uses a flag to control the invocation of Finalize: | |
886b5a18 | 8746 | |
df3e68b1 HK |
8747 | -- procedure Deep_Finalize |
8748 | -- (Obj : in out Some_Type; | |
8749 | -- Flag : Boolean := True) | |
8750 | -- is | |
8751 | -- begin | |
8752 | -- if Flag then | |
8753 | -- Finalize (Obj); | |
8754 | -- end if; | |
8755 | -- ... | |
886b5a18 | 8756 | |
7c4d86c9 | 8757 | -- When Deep_Finalize is invoked for field _parent, a value of False |
df3e68b1 | 8758 | -- is provided for the flag: |
886b5a18 | 8759 | |
df3e68b1 HK |
8760 | -- Deep_Finalize (Obj._parent, False); |
8761 | ||
41c79d60 | 8762 | if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then |
df3e68b1 HK |
8763 | declare |
8764 | Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); | |
8765 | Call : Node_Id; | |
8766 | Fin_Stmt : Node_Id; | |
70482933 | 8767 | |
df3e68b1 HK |
8768 | begin |
8769 | if Needs_Finalization (Par_Typ) then | |
8770 | Call := | |
2c1b72d7 | 8771 | Make_Final_Call |
4ac2bbbd | 8772 | (Obj_Ref => |
2c1b72d7 AC |
8773 | Make_Selected_Component (Loc, |
8774 | Prefix => Make_Identifier (Loc, Name_V), | |
8775 | Selector_Name => | |
8776 | Make_Identifier (Loc, Name_uParent)), | |
4ac2bbbd AC |
8777 | Typ => Par_Typ, |
8778 | Skip_Self => True); | |
df3e68b1 HK |
8779 | |
8780 | -- Generate: | |
7bf911b5 | 8781 | -- begin |
df3e68b1 | 8782 | -- Deep_Finalize (V._parent, False); |
7bf911b5 | 8783 | |
df3e68b1 HK |
8784 | -- exception |
8785 | -- when Id : others => | |
8786 | -- if not Raised then | |
8787 | -- Raised := True; | |
8788 | -- Save_Occurrence (E, | |
8789 | -- Get_Current_Excep.all.all); | |
8790 | -- end if; | |
8791 | -- end; | |
8792 | ||
8793 | if Present (Call) then | |
8794 | Fin_Stmt := Call; | |
8795 | ||
8796 | if Exceptions_OK then | |
8797 | Fin_Stmt := | |
8798 | Make_Block_Statement (Loc, | |
8799 | Handled_Statement_Sequence => | |
8800 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 8801 | Statements => New_List (Fin_Stmt), |
df3e68b1 HK |
8802 | Exception_Handlers => New_List ( |
8803 | Build_Exception_Handler | |
36b8f95f | 8804 | (Finalizer_Data)))); |
df3e68b1 | 8805 | end if; |
70482933 | 8806 | |
df3e68b1 HK |
8807 | Append_To (Bod_Stmts, Fin_Stmt); |
8808 | end if; | |
8809 | end if; | |
8810 | end; | |
8811 | end if; | |
70482933 | 8812 | |
df3e68b1 HK |
8813 | -- Finalize the object. This action must be performed first before |
8814 | -- all components have been finalized. | |
70482933 | 8815 | |
41c79d60 | 8816 | if Is_Controlled (Typ) and then not Is_Local then |
df3e68b1 HK |
8817 | declare |
8818 | Fin_Stmt : Node_Id; | |
8819 | Proc : Entity_Id; | |
70482933 | 8820 | |
df3e68b1 | 8821 | begin |
ca811241 | 8822 | Proc := Find_Optional_Prim_Op (Typ, Name_Finalize); |
df3e68b1 HK |
8823 | |
8824 | -- Generate: | |
8825 | -- if F then | |
df3e68b1 HK |
8826 | -- begin |
8827 | -- Finalize (V); | |
7bf911b5 | 8828 | |
df3e68b1 HK |
8829 | -- exception |
8830 | -- when others => | |
8831 | -- if not Raised then | |
8832 | -- Raised := True; | |
8833 | -- Save_Occurrence (E, | |
8834 | -- Get_Current_Excep.all.all); | |
8835 | -- end if; | |
8836 | -- end; | |
8837 | -- end if; | |
8838 | ||
8839 | if Present (Proc) then | |
8840 | Fin_Stmt := | |
8841 | Make_Procedure_Call_Statement (Loc, | |
e4494292 | 8842 | Name => New_Occurrence_Of (Proc, Loc), |
df3e68b1 HK |
8843 | Parameter_Associations => New_List ( |
8844 | Make_Identifier (Loc, Name_V))); | |
8845 | ||
8846 | if Exceptions_OK then | |
8847 | Fin_Stmt := | |
8848 | Make_Block_Statement (Loc, | |
8849 | Handled_Statement_Sequence => | |
8850 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 8851 | Statements => New_List (Fin_Stmt), |
df3e68b1 HK |
8852 | Exception_Handlers => New_List ( |
8853 | Build_Exception_Handler | |
36b8f95f | 8854 | (Finalizer_Data)))); |
df3e68b1 | 8855 | end if; |
70482933 | 8856 | |
df3e68b1 HK |
8857 | Prepend_To (Bod_Stmts, |
8858 | Make_If_Statement (Loc, | |
2c1b72d7 | 8859 | Condition => Make_Identifier (Loc, Name_F), |
df3e68b1 HK |
8860 | Then_Statements => New_List (Fin_Stmt))); |
8861 | end if; | |
8862 | end; | |
70482933 | 8863 | end if; |
70482933 | 8864 | |
df3e68b1 HK |
8865 | -- At this point either all finalization statements have been |
8866 | -- generated or the type is not controlled. | |
70482933 | 8867 | |
df3e68b1 HK |
8868 | if No (Bod_Stmts) then |
8869 | return New_List (Make_Null_Statement (Loc)); | |
70482933 | 8870 | |
df3e68b1 HK |
8871 | -- Generate: |
8872 | -- declare | |
14848f57 | 8873 | -- Abort : constant Boolean := Triggered_By_Abort; |
f9ad6b62 AC |
8874 | -- <or> |
8875 | -- Abort : constant Boolean := False; -- no abort | |
8876 | ||
7f37fff1 | 8877 | -- E : Exception_Occurrence; |
df3e68b1 | 8878 | -- Raised : Boolean := False; |
70482933 | 8879 | |
df3e68b1 | 8880 | -- begin |
df3e68b1 | 8881 | -- <finalize statements> |
70482933 | 8882 | |
ca5af305 AC |
8883 | -- if Raised and then not Abort then |
8884 | -- Raise_From_Controlled_Operation (E); | |
df3e68b1 HK |
8885 | -- end if; |
8886 | -- end; | |
70482933 | 8887 | |
df3e68b1 HK |
8888 | else |
8889 | if Exceptions_OK then | |
7bf911b5 | 8890 | Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); |
df3e68b1 | 8891 | end if; |
70482933 | 8892 | |
df3e68b1 HK |
8893 | return |
8894 | New_List ( | |
8895 | Make_Block_Statement (Loc, | |
2c1b72d7 | 8896 | Declarations => |
36b8f95f | 8897 | Finalizer_Decls, |
df3e68b1 | 8898 | Handled_Statement_Sequence => |
2c1b72d7 | 8899 | Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); |
df3e68b1 HK |
8900 | end if; |
8901 | end Build_Finalize_Statements; | |
70482933 | 8902 | |
df3e68b1 HK |
8903 | ----------------------- |
8904 | -- Parent_Field_Type -- | |
8905 | ----------------------- | |
70482933 | 8906 | |
df3e68b1 HK |
8907 | function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is |
8908 | Field : Entity_Id; | |
70482933 | 8909 | |
df3e68b1 HK |
8910 | begin |
8911 | Field := First_Entity (Typ); | |
8912 | while Present (Field) loop | |
8913 | if Chars (Field) = Name_uParent then | |
8914 | return Etype (Field); | |
8915 | end if; | |
70482933 | 8916 | |
df3e68b1 HK |
8917 | Next_Entity (Field); |
8918 | end loop; | |
70482933 | 8919 | |
df3e68b1 | 8920 | -- A derived tagged type should always have a parent field |
70482933 | 8921 | |
df3e68b1 HK |
8922 | raise Program_Error; |
8923 | end Parent_Field_Type; | |
70482933 | 8924 | |
df3e68b1 HK |
8925 | --------------------------- |
8926 | -- Preprocess_Components -- | |
8927 | --------------------------- | |
70482933 | 8928 | |
df3e68b1 HK |
8929 | procedure Preprocess_Components |
8930 | (Comps : Node_Id; | |
b3143037 | 8931 | Num_Comps : out Nat; |
df3e68b1 HK |
8932 | Has_POC : out Boolean) |
8933 | is | |
8934 | Decl : Node_Id; | |
8935 | Id : Entity_Id; | |
8936 | Typ : Entity_Id; | |
70482933 | 8937 | |
df3e68b1 HK |
8938 | begin |
8939 | Num_Comps := 0; | |
8940 | Has_POC := False; | |
70482933 | 8941 | |
df3e68b1 HK |
8942 | Decl := First_Non_Pragma (Component_Items (Comps)); |
8943 | while Present (Decl) loop | |
8944 | Id := Defining_Identifier (Decl); | |
8945 | Typ := Etype (Id); | |
70482933 | 8946 | |
df3e68b1 | 8947 | -- Skip field _parent |
fbf5a39b | 8948 | |
df3e68b1 HK |
8949 | if Chars (Id) /= Name_uParent |
8950 | and then Needs_Finalization (Typ) | |
8951 | then | |
8952 | Num_Comps := Num_Comps + 1; | |
fbf5a39b | 8953 | |
df3e68b1 HK |
8954 | if Has_Access_Constraint (Id) |
8955 | and then No (Expression (Decl)) | |
8956 | then | |
8957 | Has_POC := True; | |
8958 | end if; | |
fbf5a39b | 8959 | end if; |
70482933 | 8960 | |
df3e68b1 HK |
8961 | Next_Non_Pragma (Decl); |
8962 | end loop; | |
8963 | end Preprocess_Components; | |
fbf5a39b | 8964 | |
df3e68b1 | 8965 | -- Start of processing for Make_Deep_Record_Body |
fbf5a39b | 8966 | |
df3e68b1 HK |
8967 | begin |
8968 | case Prim is | |
8969 | when Address_Case => | |
8970 | return Make_Finalize_Address_Stmts (Typ); | |
8971 | ||
8972 | when Adjust_Case => | |
8973 | return Build_Adjust_Statements (Typ); | |
70482933 RK |
8974 | |
8975 | when Finalize_Case => | |
df3e68b1 | 8976 | return Build_Finalize_Statements (Typ); |
fbf5a39b | 8977 | |
df3e68b1 HK |
8978 | when Initialize_Case => |
8979 | declare | |
8980 | Loc : constant Source_Ptr := Sloc (Typ); | |
fbf5a39b | 8981 | |
df3e68b1 HK |
8982 | begin |
8983 | if Is_Controlled (Typ) then | |
8984 | return New_List ( | |
8985 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 8986 | Name => |
e4494292 | 8987 | New_Occurrence_Of |
2c1b72d7 | 8988 | (Find_Prim_Op (Typ, Name_Of (Prim)), Loc), |
df3e68b1 HK |
8989 | Parameter_Associations => New_List ( |
8990 | Make_Identifier (Loc, Name_V)))); | |
8991 | else | |
8992 | return Empty_List; | |
8993 | end if; | |
8994 | end; | |
70482933 RK |
8995 | end case; |
8996 | end Make_Deep_Record_Body; | |
8997 | ||
8998 | ---------------------- | |
8999 | -- Make_Final_Call -- | |
9000 | ---------------------- | |
9001 | ||
9002 | function Make_Final_Call | |
4ac2bbbd AC |
9003 | (Obj_Ref : Node_Id; |
9004 | Typ : Entity_Id; | |
9005 | Skip_Self : Boolean := False) return Node_Id | |
70482933 | 9006 | is |
df3e68b1 | 9007 | Loc : constant Source_Ptr := Sloc (Obj_Ref); |
6a2e5d0f | 9008 | Atyp : Entity_Id; |
df3e68b1 HK |
9009 | Fin_Id : Entity_Id := Empty; |
9010 | Ref : Node_Id; | |
9011 | Utyp : Entity_Id; | |
70482933 RK |
9012 | |
9013 | begin | |
2168d7cc AC |
9014 | Ref := Obj_Ref; |
9015 | ||
df3e68b1 HK |
9016 | -- Recover the proper type which contains [Deep_]Finalize |
9017 | ||
70482933 RK |
9018 | if Is_Class_Wide_Type (Typ) then |
9019 | Utyp := Root_Type (Typ); | |
6a2e5d0f | 9020 | Atyp := Utyp; |
70482933 RK |
9021 | |
9022 | elsif Is_Concurrent_Type (Typ) then | |
9023 | Utyp := Corresponding_Record_Type (Typ); | |
6a2e5d0f | 9024 | Atyp := Empty; |
2168d7cc | 9025 | Ref := Convert_Concurrent (Ref, Typ); |
70482933 RK |
9026 | |
9027 | elsif Is_Private_Type (Typ) | |
198064c0 | 9028 | and then Present (Underlying_Type (Typ)) |
a3fbecee | 9029 | and then Is_Concurrent_Type (Underlying_Type (Typ)) |
70482933 | 9030 | then |
a3fbecee | 9031 | Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); |
6a2e5d0f | 9032 | Atyp := Typ; |
a3fbecee | 9033 | Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); |
df3e68b1 | 9034 | |
70482933 RK |
9035 | else |
9036 | Utyp := Typ; | |
6a2e5d0f | 9037 | Atyp := Typ; |
70482933 RK |
9038 | end if; |
9039 | ||
9040 | Utyp := Underlying_Type (Base_Type (Utyp)); | |
df3e68b1 | 9041 | Set_Assignment_OK (Ref); |
70482933 | 9042 | |
1fb63e89 | 9043 | -- Deal with untagged derivation of private views. If the parent type |
df3e68b1 HK |
9044 | -- is a protected type, Deep_Finalize is found on the corresponding |
9045 | -- record of the ancestor. | |
9046 | ||
9047 | if Is_Untagged_Derivation (Typ) then | |
9048 | if Is_Protected_Type (Typ) then | |
9049 | Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); | |
9050 | else | |
9051 | Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); | |
9052 | ||
9053 | if Is_Protected_Type (Utyp) then | |
9054 | Utyp := Corresponding_Record_Type (Utyp); | |
9055 | end if; | |
9056 | end if; | |
9057 | ||
9058 | Ref := Unchecked_Convert_To (Utyp, Ref); | |
9059 | Set_Assignment_OK (Ref); | |
9060 | end if; | |
9061 | ||
9062 | -- Deal with derived private types which do not inherit primitives from | |
9063 | -- their parents. In this case, [Deep_]Finalize can be found in the full | |
9064 | -- view of the parent type. | |
9065 | ||
2168d7cc AC |
9066 | if Present (Utyp) |
9067 | and then Is_Tagged_Type (Utyp) | |
df3e68b1 HK |
9068 | and then Is_Derived_Type (Utyp) |
9069 | and then Is_Empty_Elmt_List (Primitive_Operations (Utyp)) | |
9070 | and then Is_Private_Type (Etype (Utyp)) | |
9071 | and then Present (Full_View (Etype (Utyp))) | |
9072 | then | |
9073 | Utyp := Full_View (Etype (Utyp)); | |
9074 | Ref := Unchecked_Convert_To (Utyp, Ref); | |
9075 | Set_Assignment_OK (Ref); | |
9076 | end if; | |
9077 | ||
9078 | -- When dealing with the completion of a private type, use the base type | |
9079 | -- instead. | |
9080 | ||
2168d7cc | 9081 | if Present (Utyp) and then Utyp /= Base_Type (Utyp) then |
6a2e5d0f | 9082 | pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp)); |
df3e68b1 HK |
9083 | |
9084 | Utyp := Base_Type (Utyp); | |
9085 | Ref := Unchecked_Convert_To (Utyp, Ref); | |
9086 | Set_Assignment_OK (Ref); | |
9087 | end if; | |
9088 | ||
2168d7cc AC |
9089 | -- The underlying type may not be present due to a missing full view. In |
9090 | -- this case freezing did not take place and there is no [Deep_]Finalize | |
9091 | -- primitive to call. | |
9092 | ||
9093 | if No (Utyp) then | |
9094 | return Empty; | |
9095 | ||
9096 | elsif Skip_Self then | |
df3e68b1 | 9097 | if Has_Controlled_Component (Utyp) then |
4ac2bbbd | 9098 | if Is_Tagged_Type (Utyp) then |
ca811241 | 9099 | Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
4ac2bbbd AC |
9100 | else |
9101 | Fin_Id := TSS (Utyp, TSS_Deep_Finalize); | |
9102 | end if; | |
df3e68b1 HK |
9103 | end if; |
9104 | ||
d3f70b35 | 9105 | -- Class-wide types, interfaces and types with controlled components |
df3e68b1 HK |
9106 | |
9107 | elsif Is_Class_Wide_Type (Typ) | |
9108 | or else Is_Interface (Typ) | |
9109 | or else Has_Controlled_Component (Utyp) | |
9110 | then | |
9111 | if Is_Tagged_Type (Utyp) then | |
ca811241 | 9112 | Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
df3e68b1 HK |
9113 | else |
9114 | Fin_Id := TSS (Utyp, TSS_Deep_Finalize); | |
9115 | end if; | |
9116 | ||
d3cb4cc0 AC |
9117 | -- Derivations from [Limited_]Controlled |
9118 | ||
9119 | elsif Is_Controlled (Utyp) then | |
9120 | if Has_Controlled_Component (Utyp) then | |
ca811241 | 9121 | Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
d3cb4cc0 | 9122 | else |
ca811241 | 9123 | Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case)); |
d3cb4cc0 AC |
9124 | end if; |
9125 | ||
d3f70b35 AC |
9126 | -- Tagged types |
9127 | ||
9128 | elsif Is_Tagged_Type (Utyp) then | |
ca811241 | 9129 | Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); |
df3e68b1 | 9130 | |
14803949 AC |
9131 | -- Protected types: these also require finalization even though they |
9132 | -- are not marked controlled explicitly. | |
9133 | ||
9134 | elsif Is_Protected_Type (Typ) then | |
9135 | -- Protected objects do not need to be finalized on restricted | |
9136 | -- runtimes. | |
9137 | ||
9138 | if Restricted_Profile then | |
9139 | return Empty; | |
9140 | ||
9141 | -- ??? Only handle the simple case for now. Will not support a record | |
9142 | -- or array containing protected objects. | |
9143 | ||
9144 | elsif Is_Simple_Protected_Type (Typ) then | |
9145 | Fin_Id := RTE (RE_Finalize_Protection); | |
9146 | else | |
9147 | raise Program_Error; | |
9148 | end if; | |
df3e68b1 | 9149 | else |
d3f70b35 | 9150 | raise Program_Error; |
df3e68b1 HK |
9151 | end if; |
9152 | ||
9153 | if Present (Fin_Id) then | |
9154 | ||
9155 | -- When finalizing a class-wide object, do not convert to the root | |
9156 | -- type in order to produce a dispatching call. | |
9157 | ||
9158 | if Is_Class_Wide_Type (Typ) then | |
9159 | null; | |
9160 | ||
9161 | -- Ensure that a finalization routine is at least decorated in order | |
9162 | -- to inspect the object parameter. | |
9163 | ||
9164 | elsif Analyzed (Fin_Id) | |
9165 | or else Ekind (Fin_Id) = E_Procedure | |
9166 | then | |
9167 | -- In certain cases, such as the creation of Stream_Read, the | |
9168 | -- visible entity of the type is its full view. Since Stream_Read | |
9169 | -- will have to create an object of type Typ, the local object | |
9170 | -- will be finalzed by the scope finalizer generated later on. The | |
9171 | -- object parameter of Deep_Finalize will always use the private | |
9172 | -- view of the type. To avoid such a clash between a private and a | |
9173 | -- full view, perform an unchecked conversion of the object | |
9174 | -- reference to the private view. | |
9175 | ||
9176 | declare | |
9177 | Formal_Typ : constant Entity_Id := | |
9178 | Etype (First_Formal (Fin_Id)); | |
9179 | begin | |
9180 | if Is_Private_Type (Formal_Typ) | |
9181 | and then Present (Full_View (Formal_Typ)) | |
9182 | and then Full_View (Formal_Typ) = Utyp | |
9183 | then | |
9184 | Ref := Unchecked_Convert_To (Formal_Typ, Ref); | |
9185 | end if; | |
9186 | end; | |
9187 | ||
25a76d62 EB |
9188 | -- If the object is unanalyzed, set its expected type for use in |
9189 | -- Convert_View in case an additional conversion is needed. | |
9190 | ||
9191 | if No (Etype (Ref)) | |
9192 | and then Nkind (Ref) /= N_Unchecked_Type_Conversion | |
9193 | then | |
9194 | Set_Etype (Ref, Typ); | |
9195 | end if; | |
9196 | ||
df3e68b1 HK |
9197 | Ref := Convert_View (Fin_Id, Ref); |
9198 | end if; | |
9199 | ||
4ac2bbbd AC |
9200 | return |
9201 | Make_Call (Loc, | |
9202 | Proc_Id => Fin_Id, | |
2168d7cc | 9203 | Param => Ref, |
4ac2bbbd | 9204 | Skip_Self => Skip_Self); |
df3e68b1 HK |
9205 | else |
9206 | return Empty; | |
9207 | end if; | |
9208 | end Make_Final_Call; | |
9209 | ||
9210 | -------------------------------- | |
9211 | -- Make_Finalize_Address_Body -- | |
9212 | -------------------------------- | |
9213 | ||
9214 | procedure Make_Finalize_Address_Body (Typ : Entity_Id) is | |
ca5af305 AC |
9215 | Is_Task : constant Boolean := |
9216 | Ekind (Typ) = E_Record_Type | |
9217 | and then Is_Concurrent_Record_Type (Typ) | |
9218 | and then Ekind (Corresponding_Concurrent_Type (Typ)) = | |
36295779 | 9219 | E_Task_Type; |
d3f70b35 AC |
9220 | Loc : constant Source_Ptr := Sloc (Typ); |
9221 | Proc_Id : Entity_Id; | |
ca5af305 | 9222 | Stmts : List_Id; |
d3f70b35 | 9223 | |
df3e68b1 | 9224 | begin |
ca5af305 AC |
9225 | -- The corresponding records of task types are not controlled by design. |
9226 | -- For the sake of completeness, create an empty Finalize_Address to be | |
9227 | -- used in task class-wide allocations. | |
9228 | ||
9229 | if Is_Task then | |
9230 | null; | |
9231 | ||
df3e68b1 HK |
9232 | -- Nothing to do if the type is not controlled or it already has a |
9233 | -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not | |
9234 | -- come from source. These are usually generated for completeness and | |
9235 | -- do not need the Finalize_Address primitive. | |
9236 | ||
ca5af305 | 9237 | elsif not Needs_Finalization (Typ) |
df3e68b1 HK |
9238 | or else Present (TSS (Typ, TSS_Finalize_Address)) |
9239 | or else | |
9240 | (Is_Class_Wide_Type (Typ) | |
886b5a18 AC |
9241 | and then Ekind (Root_Type (Typ)) = E_Record_Subtype |
9242 | and then not Comes_From_Source (Root_Type (Typ))) | |
df3e68b1 HK |
9243 | then |
9244 | return; | |
9245 | end if; | |
9246 | ||
94295b25 AC |
9247 | -- Do not generate Finalize_Address routine for CodePeer |
9248 | ||
89b6c83e AC |
9249 | if CodePeer_Mode then |
9250 | return; | |
9251 | end if; | |
9252 | ||
d3f70b35 AC |
9253 | Proc_Id := |
9254 | Make_Defining_Identifier (Loc, | |
9255 | Make_TSS_Name (Typ, TSS_Finalize_Address)); | |
df3e68b1 | 9256 | |
d3f70b35 | 9257 | -- Generate: |
886b5a18 | 9258 | |
d3f70b35 AC |
9259 | -- procedure <Typ>FD (V : System.Address) is |
9260 | -- begin | |
ca5af305 | 9261 | -- null; -- for tasks |
886b5a18 | 9262 | |
ca5af305 | 9263 | -- declare -- for all other types |
d3f70b35 AC |
9264 | -- type Pnn is access all Typ; |
9265 | -- for Pnn'Storage_Size use 0; | |
9266 | -- begin | |
9267 | -- [Deep_]Finalize (Pnn (V).all); | |
9268 | -- end; | |
9269 | -- end TypFD; | |
df3e68b1 | 9270 | |
ca5af305 AC |
9271 | if Is_Task then |
9272 | Stmts := New_List (Make_Null_Statement (Loc)); | |
9273 | else | |
9274 | Stmts := Make_Finalize_Address_Stmts (Typ); | |
9275 | end if; | |
9276 | ||
d3f70b35 AC |
9277 | Discard_Node ( |
9278 | Make_Subprogram_Body (Loc, | |
9279 | Specification => | |
9280 | Make_Procedure_Specification (Loc, | |
9281 | Defining_Unit_Name => Proc_Id, | |
df3e68b1 | 9282 | |
d3f70b35 AC |
9283 | Parameter_Specifications => New_List ( |
9284 | Make_Parameter_Specification (Loc, | |
9285 | Defining_Identifier => | |
9286 | Make_Defining_Identifier (Loc, Name_V), | |
9287 | Parameter_Type => | |
e4494292 | 9288 | New_Occurrence_Of (RTE (RE_Address), Loc)))), |
df3e68b1 | 9289 | |
d3f70b35 | 9290 | Declarations => No_List, |
df3e68b1 | 9291 | |
d3f70b35 AC |
9292 | Handled_Statement_Sequence => |
9293 | Make_Handled_Sequence_Of_Statements (Loc, | |
ca5af305 | 9294 | Statements => Stmts))); |
df3e68b1 | 9295 | |
d3f70b35 | 9296 | Set_TSS (Typ, Proc_Id); |
df3e68b1 HK |
9297 | end Make_Finalize_Address_Body; |
9298 | ||
9299 | --------------------------------- | |
9300 | -- Make_Finalize_Address_Stmts -- | |
9301 | --------------------------------- | |
9302 | ||
9303 | function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is | |
2168d7cc AC |
9304 | Loc : constant Source_Ptr := Sloc (Typ); |
9305 | ||
9306 | Decls : List_Id; | |
9307 | Desig_Typ : Entity_Id; | |
9308 | Fin_Block : Node_Id; | |
9309 | Fin_Call : Node_Id; | |
9310 | Obj_Expr : Node_Id; | |
9311 | Ptr_Typ : Entity_Id; | |
70482933 | 9312 | |
df3e68b1 HK |
9313 | begin |
9314 | if Is_Array_Type (Typ) then | |
9315 | if Is_Constrained (First_Subtype (Typ)) then | |
2168d7cc | 9316 | Desig_Typ := First_Subtype (Typ); |
f4d379b8 | 9317 | else |
2168d7cc | 9318 | Desig_Typ := Base_Type (Typ); |
f4d379b8 HK |
9319 | end if; |
9320 | ||
df3e68b1 HK |
9321 | -- Class-wide types of constrained root types |
9322 | ||
9323 | elsif Is_Class_Wide_Type (Typ) | |
9324 | and then Has_Discriminants (Root_Type (Typ)) | |
2c1b72d7 AC |
9325 | and then not |
9326 | Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ))) | |
df3e68b1 HK |
9327 | then |
9328 | declare | |
886b5a18 | 9329 | Parent_Typ : Entity_Id; |
f4d379b8 | 9330 | |
df3e68b1 HK |
9331 | begin |
9332 | -- Climb the parent type chain looking for a non-constrained type | |
f4d379b8 | 9333 | |
886b5a18 | 9334 | Parent_Typ := Root_Type (Typ); |
df3e68b1 HK |
9335 | while Parent_Typ /= Etype (Parent_Typ) |
9336 | and then Has_Discriminants (Parent_Typ) | |
2c1b72d7 AC |
9337 | and then not |
9338 | Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ)) | |
df3e68b1 HK |
9339 | loop |
9340 | Parent_Typ := Etype (Parent_Typ); | |
9341 | end loop; | |
70482933 | 9342 | |
df3e68b1 HK |
9343 | -- Handle views created for tagged types with unknown |
9344 | -- discriminants. | |
70482933 | 9345 | |
df3e68b1 HK |
9346 | if Is_Underlying_Record_View (Parent_Typ) then |
9347 | Parent_Typ := Underlying_Record_View (Parent_Typ); | |
9348 | end if; | |
9349 | ||
2168d7cc | 9350 | Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); |
df3e68b1 HK |
9351 | end; |
9352 | ||
9353 | -- General case | |
9354 | ||
9355 | else | |
2168d7cc | 9356 | Desig_Typ := Typ; |
70482933 RK |
9357 | end if; |
9358 | ||
9359 | -- Generate: | |
df3e68b1 HK |
9360 | -- type Ptr_Typ is access all Typ; |
9361 | -- for Ptr_Typ'Storage_Size use 0; | |
9362 | ||
2168d7cc AC |
9363 | Ptr_Typ := Make_Temporary (Loc, 'P'); |
9364 | ||
df3e68b1 HK |
9365 | Decls := New_List ( |
9366 | Make_Full_Type_Declaration (Loc, | |
9367 | Defining_Identifier => Ptr_Typ, | |
cfae2bed | 9368 | Type_Definition => |
df3e68b1 | 9369 | Make_Access_To_Object_Definition (Loc, |
cfae2bed | 9370 | All_Present => True, |
2168d7cc | 9371 | Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))), |
df3e68b1 HK |
9372 | |
9373 | Make_Attribute_Definition_Clause (Loc, | |
e4494292 | 9374 | Name => New_Occurrence_Of (Ptr_Typ, Loc), |
2c1b72d7 AC |
9375 | Chars => Name_Storage_Size, |
9376 | Expression => Make_Integer_Literal (Loc, 0))); | |
df3e68b1 HK |
9377 | |
9378 | Obj_Expr := Make_Identifier (Loc, Name_V); | |
9379 | ||
9380 | -- Unconstrained arrays require special processing in order to retrieve | |
9381 | -- the elements. To achieve this, we have to skip the dope vector which | |
d9b056ea | 9382 | -- lays in front of the elements and then use a thin pointer to perform |
df3e68b1 HK |
9383 | -- the address-to-access conversion. |
9384 | ||
9385 | if Is_Array_Type (Typ) | |
9386 | and then not Is_Constrained (First_Subtype (Typ)) | |
70482933 | 9387 | then |
df3e68b1 | 9388 | declare |
203ddcea | 9389 | Dope_Id : Entity_Id; |
70482933 | 9390 | |
df3e68b1 HK |
9391 | begin |
9392 | -- Ensure that Ptr_Typ a thin pointer, generate: | |
df3e68b1 | 9393 | -- for Ptr_Typ'Size use System.Address'Size; |
70482933 | 9394 | |
df3e68b1 HK |
9395 | Append_To (Decls, |
9396 | Make_Attribute_Definition_Clause (Loc, | |
e4494292 | 9397 | Name => New_Occurrence_Of (Ptr_Typ, Loc), |
2c1b72d7 | 9398 | Chars => Name_Size, |
df3e68b1 HK |
9399 | Expression => |
9400 | Make_Integer_Literal (Loc, System_Address_Size))); | |
70482933 | 9401 | |
df3e68b1 | 9402 | -- Generate: |
203ddcea | 9403 | -- Dnn : constant Storage_Offset := |
2168d7cc | 9404 | -- Desig_Typ'Descriptor_Size / Storage_Unit; |
df3e68b1 HK |
9405 | |
9406 | Dope_Id := Make_Temporary (Loc, 'D'); | |
9407 | ||
9408 | Append_To (Decls, | |
9409 | Make_Object_Declaration (Loc, | |
9410 | Defining_Identifier => Dope_Id, | |
2c1b72d7 AC |
9411 | Constant_Present => True, |
9412 | Object_Definition => | |
e4494292 | 9413 | New_Occurrence_Of (RTE (RE_Storage_Offset), Loc), |
203ddcea AC |
9414 | Expression => |
9415 | Make_Op_Divide (Loc, | |
9416 | Left_Opnd => | |
9417 | Make_Attribute_Reference (Loc, | |
2168d7cc | 9418 | Prefix => New_Occurrence_Of (Desig_Typ, Loc), |
203ddcea AC |
9419 | Attribute_Name => Name_Descriptor_Size), |
9420 | Right_Opnd => | |
9421 | Make_Integer_Literal (Loc, System_Storage_Unit)))); | |
df3e68b1 HK |
9422 | |
9423 | -- Shift the address from the start of the dope vector to the | |
9424 | -- start of the elements: | |
9425 | -- | |
9426 | -- V + Dnn | |
9427 | -- | |
9428 | -- Note that this is done through a wrapper routine since RTSfind | |
9429 | -- cannot retrieve operations with string names of the form "+". | |
9430 | ||
9431 | Obj_Expr := | |
9432 | Make_Function_Call (Loc, | |
2c1b72d7 | 9433 | Name => |
e4494292 | 9434 | New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc), |
df3e68b1 HK |
9435 | Parameter_Associations => New_List ( |
9436 | Obj_Expr, | |
e4494292 | 9437 | New_Occurrence_Of (Dope_Id, Loc))); |
df3e68b1 | 9438 | end; |
70482933 RK |
9439 | end if; |
9440 | ||
2168d7cc AC |
9441 | Fin_Call := |
9442 | Make_Final_Call ( | |
9443 | Obj_Ref => | |
9444 | Make_Explicit_Dereference (Loc, | |
9445 | Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), | |
9446 | Typ => Desig_Typ); | |
9447 | ||
9448 | if Present (Fin_Call) then | |
9449 | Fin_Block := | |
9450 | Make_Block_Statement (Loc, | |
9451 | Declarations => Decls, | |
9452 | Handled_Statement_Sequence => | |
9453 | Make_Handled_Sequence_Of_Statements (Loc, | |
9454 | Statements => New_List (Fin_Call))); | |
df3e68b1 | 9455 | |
2168d7cc AC |
9456 | -- Otherwise previous errors or a missing full view may prevent the |
9457 | -- proper freezing of the designated type. If this is the case, there | |
9458 | -- is no [Deep_]Finalize primitive to call. | |
df3e68b1 | 9459 | |
2168d7cc AC |
9460 | else |
9461 | Fin_Block := Make_Null_Statement (Loc); | |
9462 | end if; | |
9463 | ||
9464 | return New_List (Fin_Block); | |
df3e68b1 | 9465 | end Make_Finalize_Address_Stmts; |
70482933 | 9466 | |
dbe13a37 ES |
9467 | ------------------------------------- |
9468 | -- Make_Handler_For_Ctrl_Operation -- | |
9469 | ------------------------------------- | |
9470 | ||
9471 | -- Generate: | |
9472 | ||
9473 | -- when E : others => | |
ca5af305 | 9474 | -- Raise_From_Controlled_Operation (E); |
dbe13a37 ES |
9475 | |
9476 | -- or: | |
9477 | ||
9478 | -- when others => | |
9479 | -- raise Program_Error [finalize raised exception]; | |
9480 | ||
9481 | -- depending on whether Raise_From_Controlled_Operation is available | |
9482 | ||
9483 | function Make_Handler_For_Ctrl_Operation | |
9484 | (Loc : Source_Ptr) return Node_Id | |
9485 | is | |
9486 | E_Occ : Entity_Id; | |
9487 | -- Choice parameter (for the first case above) | |
9488 | ||
9489 | Raise_Node : Node_Id; | |
9490 | -- Procedure call or raise statement | |
9491 | ||
9492 | begin | |
57d3adcd AC |
9493 | -- Standard run-time: add choice parameter E and pass it to |
9494 | -- Raise_From_Controlled_Operation so that the original exception | |
7ae0d98c AC |
9495 | -- name and message can be recorded in the exception message for |
9496 | -- Program_Error. | |
dbe13a37 | 9497 | |
7ae0d98c | 9498 | if RTE_Available (RE_Raise_From_Controlled_Operation) then |
dbe13a37 | 9499 | E_Occ := Make_Defining_Identifier (Loc, Name_E); |
df3e68b1 HK |
9500 | Raise_Node := |
9501 | Make_Procedure_Call_Statement (Loc, | |
2c1b72d7 | 9502 | Name => |
e4494292 | 9503 | New_Occurrence_Of |
f9ad6b62 | 9504 | (RTE (RE_Raise_From_Controlled_Operation), Loc), |
df3e68b1 | 9505 | Parameter_Associations => New_List ( |
e4494292 | 9506 | New_Occurrence_Of (E_Occ, Loc))); |
dbe13a37 | 9507 | |
d72e7628 | 9508 | -- Restricted run-time: exception messages are not supported |
dbe13a37 | 9509 | |
df3e68b1 | 9510 | else |
dbe13a37 | 9511 | E_Occ := Empty; |
df3e68b1 HK |
9512 | Raise_Node := |
9513 | Make_Raise_Program_Error (Loc, | |
9514 | Reason => PE_Finalize_Raised_Exception); | |
dbe13a37 ES |
9515 | end if; |
9516 | ||
df3e68b1 HK |
9517 | return |
9518 | Make_Implicit_Exception_Handler (Loc, | |
9519 | Exception_Choices => New_List (Make_Others_Choice (Loc)), | |
9520 | Choice_Parameter => E_Occ, | |
9521 | Statements => New_List (Raise_Node)); | |
dbe13a37 ES |
9522 | end Make_Handler_For_Ctrl_Operation; |
9523 | ||
70482933 RK |
9524 | -------------------- |
9525 | -- Make_Init_Call -- | |
9526 | -------------------- | |
9527 | ||
9528 | function Make_Init_Call | |
df3e68b1 HK |
9529 | (Obj_Ref : Node_Id; |
9530 | Typ : Entity_Id) return Node_Id | |
70482933 | 9531 | is |
df3e68b1 | 9532 | Loc : constant Source_Ptr := Sloc (Obj_Ref); |
70482933 | 9533 | Is_Conc : Boolean; |
70482933 | 9534 | Proc : Entity_Id; |
df3e68b1 | 9535 | Ref : Node_Id; |
70482933 | 9536 | Utyp : Entity_Id; |
70482933 RK |
9537 | |
9538 | begin | |
2168d7cc AC |
9539 | Ref := Obj_Ref; |
9540 | ||
df3e68b1 HK |
9541 | -- Deal with the type and object reference. Depending on the context, an |
9542 | -- object reference may need several conversions. | |
9543 | ||
70482933 RK |
9544 | if Is_Concurrent_Type (Typ) then |
9545 | Is_Conc := True; | |
9546 | Utyp := Corresponding_Record_Type (Typ); | |
2168d7cc | 9547 | Ref := Convert_Concurrent (Ref, Typ); |
70482933 RK |
9548 | |
9549 | elsif Is_Private_Type (Typ) | |
9550 | and then Present (Full_View (Typ)) | |
9551 | and then Is_Concurrent_Type (Underlying_Type (Typ)) | |
9552 | then | |
9553 | Is_Conc := True; | |
9554 | Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); | |
2168d7cc | 9555 | Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); |
70482933 RK |
9556 | |
9557 | else | |
9558 | Is_Conc := False; | |
9559 | Utyp := Typ; | |
70482933 RK |
9560 | end if; |
9561 | ||
df3e68b1 | 9562 | Utyp := Underlying_Type (Base_Type (Utyp)); |
2168d7cc | 9563 | Set_Assignment_OK (Ref); |
70482933 | 9564 | |
1fb63e89 | 9565 | -- Deal with untagged derivation of private views |
70482933 | 9566 | |
41c79d60 | 9567 | if Is_Untagged_Derivation (Typ) and then not Is_Conc then |
70482933 | 9568 | Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); |
df3e68b1 | 9569 | Ref := Unchecked_Convert_To (Utyp, Ref); |
cfae2bed | 9570 | |
a4640a39 AC |
9571 | -- The following is to prevent problems with UC see 1.156 RH ??? |
9572 | ||
df3e68b1 | 9573 | Set_Assignment_OK (Ref); |
70482933 RK |
9574 | end if; |
9575 | ||
df3e68b1 HK |
9576 | -- If the underlying_type is a subtype, then we are dealing with the |
9577 | -- completion of a private type. We need to access the base type and | |
9578 | -- generate a conversion to it. | |
70482933 | 9579 | |
2168d7cc | 9580 | if Present (Utyp) and then Utyp /= Base_Type (Utyp) then |
70482933 RK |
9581 | pragma Assert (Is_Private_Type (Typ)); |
9582 | Utyp := Base_Type (Utyp); | |
df3e68b1 | 9583 | Ref := Unchecked_Convert_To (Utyp, Ref); |
70482933 RK |
9584 | end if; |
9585 | ||
2168d7cc AC |
9586 | -- The underlying type may not be present due to a missing full view. |
9587 | -- In this case freezing did not take place and there is no suitable | |
9588 | -- [Deep_]Initialize primitive to call. | |
14803949 | 9589 | -- If Typ is protected then no additional processing is needed either. |
2168d7cc | 9590 | |
14803949 AC |
9591 | if No (Utyp) |
9592 | or else Is_Protected_Type (Typ) | |
9593 | then | |
2168d7cc AC |
9594 | return Empty; |
9595 | end if; | |
9596 | ||
df3e68b1 | 9597 | -- Select the appropriate version of initialize |
70482933 | 9598 | |
df3e68b1 HK |
9599 | if Has_Controlled_Component (Utyp) then |
9600 | Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); | |
df3e68b1 HK |
9601 | else |
9602 | Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); | |
9603 | Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref); | |
70482933 RK |
9604 | end if; |
9605 | ||
1804faa4 AC |
9606 | -- If initialization procedure for an array of controlled objects is |
9607 | -- trivial, do not generate a useless call to it. | |
9608 | ||
9609 | if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc)) | |
9610 | or else | |
9611 | (not Comes_From_Source (Proc) | |
9612 | and then Present (Alias (Proc)) | |
9613 | and then Is_Trivial_Subprogram (Alias (Proc))) | |
9614 | then | |
14803949 | 9615 | return Empty; |
1804faa4 AC |
9616 | end if; |
9617 | ||
df3e68b1 HK |
9618 | -- The object reference may need another conversion depending on the |
9619 | -- type of the formal and that of the actual. | |
9620 | ||
9621 | Ref := Convert_View (Proc, Ref); | |
9622 | ||
70482933 | 9623 | -- Generate: |
df3e68b1 | 9624 | -- [Deep_]Initialize (Ref); |
70482933 | 9625 | |
df3e68b1 HK |
9626 | return |
9627 | Make_Procedure_Call_Statement (Loc, | |
2168d7cc | 9628 | Name => New_Occurrence_Of (Proc, Loc), |
df3e68b1 HK |
9629 | Parameter_Associations => New_List (Ref)); |
9630 | end Make_Init_Call; | |
70482933 | 9631 | |
df3e68b1 HK |
9632 | ------------------------------ |
9633 | -- Make_Local_Deep_Finalize -- | |
9634 | ------------------------------ | |
70482933 | 9635 | |
df3e68b1 HK |
9636 | function Make_Local_Deep_Finalize |
9637 | (Typ : Entity_Id; | |
9638 | Nam : Entity_Id) return Node_Id | |
9639 | is | |
9640 | Loc : constant Source_Ptr := Sloc (Typ); | |
9641 | Formals : List_Id; | |
70482933 | 9642 | |
df3e68b1 HK |
9643 | begin |
9644 | Formals := New_List ( | |
70482933 | 9645 | |
df3e68b1 | 9646 | -- V : in out Typ |
fbf5a39b | 9647 | |
df3e68b1 | 9648 | Make_Parameter_Specification (Loc, |
2c1b72d7 AC |
9649 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
9650 | In_Present => True, | |
9651 | Out_Present => True, | |
e4494292 | 9652 | Parameter_Type => New_Occurrence_Of (Typ, Loc)), |
70482933 | 9653 | |
df3e68b1 | 9654 | -- F : Boolean := True |
70482933 | 9655 | |
df3e68b1 | 9656 | Make_Parameter_Specification (Loc, |
2c1b72d7 | 9657 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), |
e4494292 RD |
9658 | Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), |
9659 | Expression => New_Occurrence_Of (Standard_True, Loc))); | |
df3e68b1 HK |
9660 | |
9661 | -- Add the necessary number of counters to represent the initialization | |
9662 | -- state of an object. | |
9663 | ||
9664 | return | |
9665 | Make_Subprogram_Body (Loc, | |
9666 | Specification => | |
9667 | Make_Procedure_Specification (Loc, | |
2c1b72d7 | 9668 | Defining_Unit_Name => Nam, |
df3e68b1 HK |
9669 | Parameter_Specifications => Formals), |
9670 | ||
9671 | Declarations => No_List, | |
9672 | ||
9673 | Handled_Statement_Sequence => | |
9674 | Make_Handled_Sequence_Of_Statements (Loc, | |
2c1b72d7 | 9675 | Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True))); |
df3e68b1 HK |
9676 | end Make_Local_Deep_Finalize; |
9677 | ||
b254da66 AC |
9678 | ------------------------------------ |
9679 | -- Make_Set_Finalize_Address_Call -- | |
9680 | ------------------------------------ | |
9681 | ||
9682 | function Make_Set_Finalize_Address_Call | |
59e6b23c | 9683 | (Loc : Source_Ptr; |
b254da66 AC |
9684 | Ptr_Typ : Entity_Id) return Node_Id |
9685 | is | |
b6a56408 AC |
9686 | -- It is possible for Ptr_Typ to be a partial view, if the access type |
9687 | -- is a full view declared in the private part of a nested package, and | |
9688 | -- the finalization actions take place when completing analysis of the | |
9689 | -- enclosing unit. For this reason use Underlying_Type twice below. | |
cd1a470a | 9690 | |
760804f3 | 9691 | Desig_Typ : constant Entity_Id := |
cd1a470a AC |
9692 | Available_View |
9693 | (Designated_Type (Underlying_Type (Ptr_Typ))); | |
760804f3 | 9694 | Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ); |
cd1a470a AC |
9695 | Fin_Mas : constant Entity_Id := |
9696 | Finalization_Master (Underlying_Type (Ptr_Typ)); | |
b254da66 AC |
9697 | |
9698 | begin | |
760804f3 AC |
9699 | -- Both the finalization master and primitive Finalize_Address must be |
9700 | -- available. | |
b254da66 | 9701 | |
760804f3 | 9702 | pragma Assert (Present (Fin_Addr) and Present (Fin_Mas)); |
0d566e01 | 9703 | |
b254da66 | 9704 | -- Generate: |
760804f3 AC |
9705 | -- Set_Finalize_Address |
9706 | -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access); | |
b254da66 | 9707 | |
94bbf008 | 9708 | return |
b254da66 | 9709 | Make_Procedure_Call_Statement (Loc, |
59e6b23c | 9710 | Name => |
e4494292 | 9711 | New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc), |
b254da66 | 9712 | Parameter_Associations => New_List ( |
760804f3 AC |
9713 | New_Occurrence_Of (Fin_Mas, Loc), |
9714 | ||
b254da66 | 9715 | Make_Attribute_Reference (Loc, |
760804f3 | 9716 | Prefix => New_Occurrence_Of (Fin_Addr, Loc), |
b254da66 AC |
9717 | Attribute_Name => Name_Unrestricted_Access))); |
9718 | end Make_Set_Finalize_Address_Call; | |
9719 | ||
70482933 RK |
9720 | -------------------------- |
9721 | -- Make_Transient_Block -- | |
9722 | -------------------------- | |
9723 | ||
70482933 RK |
9724 | function Make_Transient_Block |
9725 | (Loc : Source_Ptr; | |
df3e68b1 HK |
9726 | Action : Node_Id; |
9727 | Par : Node_Id) return Node_Id | |
70482933 | 9728 | is |
f32eb591 AC |
9729 | function Manages_Sec_Stack (Id : Entity_Id) return Boolean; |
9730 | -- Determine whether scoping entity Id manages the secondary stack | |
70482933 | 9731 | |
f2c2cdfb HK |
9732 | function Within_Loop_Statement (N : Node_Id) return Boolean; |
9733 | -- Return True when N appears within a loop and no block is containing N | |
01bd58f5 | 9734 | |
f32eb591 AC |
9735 | ----------------------- |
9736 | -- Manages_Sec_Stack -- | |
9737 | ----------------------- | |
70482933 | 9738 | |
f32eb591 AC |
9739 | function Manages_Sec_Stack (Id : Entity_Id) return Boolean is |
9740 | begin | |
7a71a7c4 | 9741 | case Ekind (Id) is |
c1fd002c | 9742 | |
7a71a7c4 AC |
9743 | -- An exception handler with a choice parameter utilizes a dummy |
9744 | -- block to provide a declarative region. Such a block should not | |
9745 | -- be considered because it never manifests in the tree and can | |
9746 | -- never release the secondary stack. | |
70482933 | 9747 | |
7a71a7c4 AC |
9748 | when E_Block => |
9749 | return | |
9750 | Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id); | |
70482933 | 9751 | |
7a71a7c4 AC |
9752 | when E_Entry |
9753 | | E_Entry_Family | |
9754 | | E_Function | |
9755 | | E_Procedure | |
9756 | => | |
9757 | return Uses_Sec_Stack (Id); | |
9758 | ||
9759 | when others => | |
9760 | return False; | |
9761 | end case; | |
f32eb591 | 9762 | end Manages_Sec_Stack; |
70482933 | 9763 | |
f2c2cdfb HK |
9764 | --------------------------- |
9765 | -- Within_Loop_Statement -- | |
9766 | --------------------------- | |
9767 | ||
9768 | function Within_Loop_Statement (N : Node_Id) return Boolean is | |
9769 | Par : Node_Id := Parent (N); | |
9770 | ||
9771 | begin | |
4a08c95c AC |
9772 | while Nkind (Par) not in |
9773 | N_Handled_Sequence_Of_Statements | N_Loop_Statement | | |
9774 | N_Package_Specification | N_Proper_Body | |
f2c2cdfb HK |
9775 | loop |
9776 | pragma Assert (Present (Par)); | |
9777 | Par := Parent (Par); | |
9778 | end loop; | |
9779 | ||
9780 | return Nkind (Par) = N_Loop_Statement; | |
9781 | end Within_Loop_Statement; | |
9782 | ||
f32eb591 | 9783 | -- Local variables |
70482933 | 9784 | |
f32eb591 AC |
9785 | Decls : constant List_Id := New_List; |
9786 | Instrs : constant List_Id := New_List (Action); | |
9787 | Trans_Id : constant Entity_Id := Current_Scope; | |
70482933 | 9788 | |
f32eb591 AC |
9789 | Block : Node_Id; |
9790 | Insert : Node_Id; | |
9791 | Scop : Entity_Id; | |
70482933 | 9792 | |
f32eb591 | 9793 | -- Start of processing for Make_Transient_Block |
70482933 | 9794 | |
f32eb591 AC |
9795 | begin |
9796 | -- Even though the transient block is tasked with managing the secondary | |
9797 | -- stack, the block may forgo this functionality depending on how the | |
9798 | -- secondary stack is managed by enclosing scopes. | |
70482933 | 9799 | |
f32eb591 | 9800 | if Manages_Sec_Stack (Trans_Id) then |
75a957f5 | 9801 | |
f32eb591 AC |
9802 | -- Determine whether an enclosing scope already manages the secondary |
9803 | -- stack. | |
75a957f5 | 9804 | |
f32eb591 AC |
9805 | Scop := Scope (Trans_Id); |
9806 | while Present (Scop) loop | |
70482933 | 9807 | |
7a71a7c4 AC |
9808 | -- It should not be possible to reach Standard without hitting one |
9809 | -- of the other cases first unless Standard was manually pushed. | |
f32eb591 | 9810 | |
7a71a7c4 | 9811 | if Scop = Standard_Standard then |
f32eb591 AC |
9812 | exit; |
9813 | ||
9814 | -- The transient block is within a function which returns on the | |
9815 | -- secondary stack. Take a conservative approach and assume that | |
9816 | -- the value on the secondary stack is part of the result. Note | |
9817 | -- that it is not possible to detect this dependency without flow | |
9818 | -- analysis which the compiler does not have. Letting the object | |
9819 | -- live longer than the transient block will not leak any memory | |
9820 | -- because the caller will reclaim the total storage used by the | |
9821 | -- function. | |
9822 | ||
9823 | elsif Ekind (Scop) = E_Function | |
9824 | and then Sec_Stack_Needed_For_Return (Scop) | |
9825 | then | |
9826 | Set_Uses_Sec_Stack (Trans_Id, False); | |
9827 | exit; | |
9828 | ||
7a71a7c4 AC |
9829 | -- The transient block must manage the secondary stack when the |
9830 | -- block appears within a loop in order to reclaim the memory at | |
9831 | -- each iteration. | |
9832 | ||
9833 | elsif Ekind (Scop) = E_Loop then | |
9834 | exit; | |
9835 | ||
01bd58f5 JM |
9836 | -- Ditto when the block appears without a block that does not |
9837 | -- manage the secondary stack and is located within a loop. | |
9838 | ||
9839 | elsif Ekind (Scop) = E_Block | |
9840 | and then not Manages_Sec_Stack (Scop) | |
9841 | and then Present (Block_Node (Scop)) | |
9842 | and then Within_Loop_Statement (Block_Node (Scop)) | |
9843 | then | |
9844 | exit; | |
9845 | ||
7a71a7c4 AC |
9846 | -- The transient block does not need to manage the secondary stack |
9847 | -- when there is an enclosing construct which already does that. | |
f32eb591 AC |
9848 | -- This optimization saves on SS_Mark and SS_Release calls but may |
9849 | -- allow objects to live a little longer than required. | |
9850 | ||
7a71a7c4 AC |
9851 | -- The transient block must manage the secondary stack when switch |
9852 | -- -gnatd.s (strict management) is in effect. | |
9853 | ||
9854 | elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then | |
f32eb591 AC |
9855 | Set_Uses_Sec_Stack (Trans_Id, False); |
9856 | exit; | |
7a71a7c4 AC |
9857 | |
9858 | -- Prevent the search from going too far because transient blocks | |
9859 | -- are bounded by packages and subprogram scopes. | |
9860 | ||
4a08c95c AC |
9861 | elsif Ekind (Scop) in E_Entry |
9862 | | E_Entry_Family | |
9863 | | E_Function | |
9864 | | E_Package | |
9865 | | E_Procedure | |
9866 | | E_Subprogram_Body | |
7a71a7c4 AC |
9867 | then |
9868 | exit; | |
f32eb591 AC |
9869 | end if; |
9870 | ||
9871 | Scop := Scope (Scop); | |
9872 | end loop; | |
70482933 RK |
9873 | end if; |
9874 | ||
df3e68b1 | 9875 | -- Create the transient block. Set the parent now since the block itself |
f32eb591 AC |
9876 | -- is not part of the tree. The current scope is the E_Block entity that |
9877 | -- has been pushed by Establish_Transient_Scope. | |
9878 | ||
9879 | pragma Assert (Ekind (Trans_Id) = E_Block); | |
70482933 | 9880 | |
df3e68b1 | 9881 | Block := |
70482933 | 9882 | Make_Block_Statement (Loc, |
f32eb591 | 9883 | Identifier => New_Occurrence_Of (Trans_Id, Loc), |
2c1b72d7 | 9884 | Declarations => Decls, |
70482933 | 9885 | Handled_Statement_Sequence => |
2c1b72d7 AC |
9886 | Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), |
9887 | Has_Created_Identifier => True); | |
df3e68b1 HK |
9888 | Set_Parent (Block, Par); |
9889 | ||
9890 | -- Insert actions stuck in the transient scopes as well as all freezing | |
8071b771 AC |
9891 | -- nodes needed by those actions. Do not insert cleanup actions here, |
9892 | -- they will be transferred to the newly created block. | |
df3e68b1 | 9893 | |
8e888920 AC |
9894 | Insert_Actions_In_Scope_Around |
9895 | (Action, Clean => False, Manage_SS => False); | |
df3e68b1 HK |
9896 | |
9897 | Insert := Prev (Action); | |
f32eb591 | 9898 | |
df3e68b1 | 9899 | if Present (Insert) then |
f32eb591 | 9900 | Freeze_All (First_Entity (Trans_Id), Insert); |
df3e68b1 | 9901 | end if; |
70482933 | 9902 | |
36295779 AC |
9903 | -- Transfer cleanup actions to the newly created block |
9904 | ||
9905 | declare | |
9906 | Cleanup_Actions : List_Id | |
9907 | renames Scope_Stack.Table (Scope_Stack.Last). | |
9908 | Actions_To_Be_Wrapped (Cleanup); | |
9909 | begin | |
9910 | Set_Cleanup_Actions (Block, Cleanup_Actions); | |
9911 | Cleanup_Actions := No_List; | |
9912 | end; | |
9913 | ||
886b5a18 AC |
9914 | -- When the transient scope was established, we pushed the entry for the |
9915 | -- transient scope onto the scope stack, so that the scope was active | |
9916 | -- for the installation of finalizable entities etc. Now we must remove | |
9917 | -- this entry, since we have constructed a proper block. | |
70482933 RK |
9918 | |
9919 | Pop_Scope; | |
9920 | ||
df3e68b1 | 9921 | return Block; |
70482933 RK |
9922 | end Make_Transient_Block; |
9923 | ||
9924 | ------------------------ | |
9925 | -- Node_To_Be_Wrapped -- | |
9926 | ------------------------ | |
9927 | ||
9928 | function Node_To_Be_Wrapped return Node_Id is | |
9929 | begin | |
9930 | return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; | |
9931 | end Node_To_Be_Wrapped; | |
9932 | ||
9933 | ---------------------------- | |
9934 | -- Set_Node_To_Be_Wrapped -- | |
9935 | ---------------------------- | |
9936 | ||
9937 | procedure Set_Node_To_Be_Wrapped (N : Node_Id) is | |
9938 | begin | |
9939 | Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; | |
9940 | end Set_Node_To_Be_Wrapped; | |
9941 | ||
36295779 AC |
9942 | ---------------------------- |
9943 | -- Store_Actions_In_Scope -- | |
9944 | ---------------------------- | |
70482933 | 9945 | |
36295779 AC |
9946 | procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is |
9947 | SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); | |
9948 | Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); | |
70482933 RK |
9949 | |
9950 | begin | |
fff7a6d9 | 9951 | if Is_Empty_List (Actions) then |
36295779 | 9952 | Actions := L; |
70482933 RK |
9953 | |
9954 | if Is_List_Member (SE.Node_To_Be_Wrapped) then | |
9955 | Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); | |
9956 | else | |
9957 | Set_Parent (L, SE.Node_To_Be_Wrapped); | |
9958 | end if; | |
9959 | ||
9960 | Analyze_List (L); | |
36295779 AC |
9961 | |
9962 | elsif AK = Before then | |
9963 | Insert_List_After_And_Analyze (Last (Actions), L); | |
9964 | ||
9965 | else | |
9966 | Insert_List_Before_And_Analyze (First (Actions), L); | |
70482933 | 9967 | end if; |
36295779 AC |
9968 | end Store_Actions_In_Scope; |
9969 | ||
9970 | ---------------------------------- | |
9971 | -- Store_After_Actions_In_Scope -- | |
9972 | ---------------------------------- | |
9973 | ||
9974 | procedure Store_After_Actions_In_Scope (L : List_Id) is | |
9975 | begin | |
9976 | Store_Actions_In_Scope (After, L); | |
70482933 RK |
9977 | end Store_After_Actions_In_Scope; |
9978 | ||
9979 | ----------------------------------- | |
9980 | -- Store_Before_Actions_In_Scope -- | |
9981 | ----------------------------------- | |
9982 | ||
9983 | procedure Store_Before_Actions_In_Scope (L : List_Id) is | |
70482933 | 9984 | begin |
36295779 AC |
9985 | Store_Actions_In_Scope (Before, L); |
9986 | end Store_Before_Actions_In_Scope; | |
70482933 | 9987 | |
36295779 AC |
9988 | ----------------------------------- |
9989 | -- Store_Cleanup_Actions_In_Scope -- | |
9990 | ----------------------------------- | |
70482933 | 9991 | |
36295779 AC |
9992 | procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is |
9993 | begin | |
9994 | Store_Actions_In_Scope (Cleanup, L); | |
9995 | end Store_Cleanup_Actions_In_Scope; | |
70482933 | 9996 | |
f68289d8 GD |
9997 | ------------------ |
9998 | -- Unnest_Block -- | |
9999 | ------------------ | |
10000 | ||
10001 | procedure Unnest_Block (Decl : Node_Id) is | |
10002 | Loc : constant Source_Ptr := Sloc (Decl); | |
10003 | Ent : Entity_Id; | |
10004 | Local_Body : Node_Id; | |
10005 | Local_Call : Node_Id; | |
10006 | Local_Proc : Entity_Id; | |
10007 | Local_Scop : Entity_Id; | |
10008 | ||
10009 | begin | |
10010 | Local_Scop := Entity (Identifier (Decl)); | |
10011 | Ent := First_Entity (Local_Scop); | |
10012 | ||
10013 | Local_Proc := | |
10014 | Make_Defining_Identifier (Loc, | |
10015 | Chars => New_Internal_Name ('P')); | |
10016 | ||
10017 | Local_Body := | |
10018 | Make_Subprogram_Body (Loc, | |
10019 | Specification => | |
10020 | Make_Procedure_Specification (Loc, | |
10021 | Defining_Unit_Name => Local_Proc), | |
10022 | Declarations => Declarations (Decl), | |
10023 | Handled_Statement_Sequence => | |
10024 | Handled_Statement_Sequence (Decl)); | |
10025 | ||
05746958 GD |
10026 | -- Handlers in the block may contain nested subprograms that require |
10027 | -- unnesting. | |
10028 | ||
10029 | Check_Unnesting_In_Handlers (Local_Body); | |
10030 | ||
f68289d8 GD |
10031 | Rewrite (Decl, Local_Body); |
10032 | Analyze (Decl); | |
10033 | Set_Has_Nested_Subprogram (Local_Proc); | |
10034 | ||
10035 | Local_Call := | |
10036 | Make_Procedure_Call_Statement (Loc, | |
10037 | Name => New_Occurrence_Of (Local_Proc, Loc)); | |
10038 | ||
10039 | Insert_After (Decl, Local_Call); | |
10040 | Analyze (Local_Call); | |
10041 | ||
10042 | -- The new subprogram has the same scope as the original block | |
10043 | ||
10044 | Set_Scope (Local_Proc, Scope (Local_Scop)); | |
10045 | ||
10046 | -- And the entity list of the new procedure is that of the block | |
10047 | ||
10048 | Set_First_Entity (Local_Proc, Ent); | |
10049 | ||
10050 | -- Reset the scopes of all the entities to the new procedure | |
10051 | ||
10052 | while Present (Ent) loop | |
10053 | Set_Scope (Ent, Local_Proc); | |
10054 | Next_Entity (Ent); | |
10055 | end loop; | |
10056 | end Unnest_Block; | |
10057 | ||
05746958 GD |
10058 | ------------------------- |
10059 | -- Unnest_If_Statement -- | |
10060 | ------------------------- | |
10061 | ||
10062 | procedure Unnest_If_Statement (If_Stmt : Node_Id) is | |
10063 | ||
10064 | procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id); | |
10065 | -- A list of statements (that may be a list associated with a then, | |
10066 | -- elsif, or else part of an if-statement) is traversed at the top | |
10067 | -- level to determine whether it contains a subprogram body, and if so, | |
10068 | -- the statements will be replaced with a new procedure body containing | |
10069 | -- the statements followed by a call to the procedure. The individual | |
10070 | -- statements may also be blocks, loops, or other if statements that | |
10071 | -- themselves may require contain nested subprograms needing unnesting. | |
10072 | ||
10073 | procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is | |
10074 | Subp_Found : Boolean := False; | |
10075 | ||
10076 | begin | |
10077 | if Is_Empty_List (Stmts) then | |
10078 | return; | |
10079 | end if; | |
10080 | ||
10081 | declare | |
10082 | Stmt : Node_Id := First (Stmts); | |
10083 | begin | |
10084 | while Present (Stmt) loop | |
10085 | if Nkind (Stmt) = N_Subprogram_Body then | |
10086 | Subp_Found := True; | |
10087 | exit; | |
10088 | end if; | |
10089 | ||
10090 | Next (Stmt); | |
10091 | end loop; | |
10092 | end; | |
10093 | ||
10094 | -- The statements themselves may be blocks, loops, etc. that in turn | |
10095 | -- contain nested subprograms requiring an unnesting transformation. | |
10096 | -- We perform this traversal after looking for subprogram bodies, to | |
10097 | -- avoid considering procedures created for one of those statements | |
10098 | -- (such as a block rewritten as a procedure) as a nested subprogram | |
10099 | -- of the statement list (which could result in an unneeded wrapper | |
10100 | -- procedure). | |
10101 | ||
10102 | Check_Unnesting_In_Decls_Or_Stmts (Stmts); | |
10103 | ||
10104 | -- If there was a top-level subprogram body in the statement list, | |
10105 | -- then perform an unnesting transformation on the list by replacing | |
10106 | -- the statements with a wrapper procedure body containing the | |
10107 | -- original statements followed by a call to that procedure. | |
10108 | ||
10109 | if Subp_Found then | |
10110 | Unnest_Statement_List (Stmts); | |
10111 | end if; | |
10112 | end Check_Stmts_For_Subp_Unnesting; | |
10113 | ||
10114 | -- Local variables | |
10115 | ||
10116 | Then_Stmts : List_Id := Then_Statements (If_Stmt); | |
10117 | Else_Stmts : List_Id := Else_Statements (If_Stmt); | |
10118 | ||
10119 | -- Start of processing for Unnest_If_Statement | |
10120 | ||
10121 | begin | |
10122 | Check_Stmts_For_Subp_Unnesting (Then_Stmts); | |
10123 | Set_Then_Statements (If_Stmt, Then_Stmts); | |
10124 | ||
10125 | if not Is_Empty_List (Elsif_Parts (If_Stmt)) then | |
10126 | declare | |
10127 | Elsif_Part : Node_Id := | |
10128 | First (Elsif_Parts (If_Stmt)); | |
10129 | Elsif_Stmts : List_Id; | |
10130 | begin | |
10131 | while Present (Elsif_Part) loop | |
10132 | Elsif_Stmts := Then_Statements (Elsif_Part); | |
10133 | ||
10134 | Check_Stmts_For_Subp_Unnesting (Elsif_Stmts); | |
10135 | Set_Then_Statements (Elsif_Part, Elsif_Stmts); | |
10136 | ||
10137 | Next (Elsif_Part); | |
10138 | end loop; | |
10139 | end; | |
10140 | end if; | |
10141 | ||
10142 | Check_Stmts_For_Subp_Unnesting (Else_Stmts); | |
10143 | Set_Else_Statements (If_Stmt, Else_Stmts); | |
10144 | end Unnest_If_Statement; | |
10145 | ||
7e536bfd GD |
10146 | ----------------- |
10147 | -- Unnest_Loop -- | |
10148 | ----------------- | |
10149 | ||
10150 | procedure Unnest_Loop (Loop_Stmt : Node_Id) is | |
10151 | Loc : constant Source_Ptr := Sloc (Loop_Stmt); | |
10152 | Ent : Entity_Id; | |
10153 | Local_Body : Node_Id; | |
10154 | Local_Call : Node_Id; | |
10155 | Local_Proc : Entity_Id; | |
10156 | Local_Scop : Entity_Id; | |
10157 | Loop_Copy : constant Node_Id := | |
10158 | Relocate_Node (Loop_Stmt); | |
10159 | begin | |
10160 | Local_Scop := Entity (Identifier (Loop_Stmt)); | |
10161 | Ent := First_Entity (Local_Scop); | |
10162 | ||
10163 | Local_Proc := | |
10164 | Make_Defining_Identifier (Loc, | |
10165 | Chars => New_Internal_Name ('P')); | |
10166 | ||
10167 | Local_Body := | |
10168 | Make_Subprogram_Body (Loc, | |
10169 | Specification => | |
10170 | Make_Procedure_Specification (Loc, | |
10171 | Defining_Unit_Name => Local_Proc), | |
10172 | Declarations => Empty_List, | |
10173 | Handled_Statement_Sequence => | |
10174 | Make_Handled_Sequence_Of_Statements (Loc, | |
10175 | Statements => New_List (Loop_Copy))); | |
10176 | ||
10177 | Set_First_Real_Statement | |
10178 | (Handled_Statement_Sequence (Local_Body), Loop_Copy); | |
10179 | ||
10180 | Rewrite (Loop_Stmt, Local_Body); | |
10181 | Analyze (Loop_Stmt); | |
10182 | ||
10183 | Set_Has_Nested_Subprogram (Local_Proc); | |
10184 | ||
10185 | Local_Call := | |
10186 | Make_Procedure_Call_Statement (Loc, | |
10187 | Name => New_Occurrence_Of (Local_Proc, Loc)); | |
10188 | ||
10189 | Insert_After (Loop_Stmt, Local_Call); | |
10190 | Analyze (Local_Call); | |
10191 | ||
10192 | -- New procedure has the same scope as the original loop, and the scope | |
10193 | -- of the loop is the new procedure. | |
10194 | ||
10195 | Set_Scope (Local_Proc, Scope (Local_Scop)); | |
10196 | Set_Scope (Local_Scop, Local_Proc); | |
10197 | ||
10198 | -- The entity list of the new procedure is that of the loop | |
10199 | ||
10200 | Set_First_Entity (Local_Proc, Ent); | |
10201 | ||
10202 | -- Note that the entities associated with the loop don't need to have | |
10203 | -- their Scope fields reset, since they're still associated with the | |
10204 | -- same loop entity that now belongs to the copied loop statement. | |
10205 | end Unnest_Loop; | |
10206 | ||
05746958 GD |
10207 | --------------------------- |
10208 | -- Unnest_Statement_List -- | |
10209 | --------------------------- | |
10210 | ||
10211 | procedure Unnest_Statement_List (Stmts : in out List_Id) is | |
10212 | Loc : constant Source_Ptr := Sloc (First (Stmts)); | |
10213 | Local_Body : Node_Id; | |
10214 | Local_Call : Node_Id; | |
10215 | Local_Proc : Entity_Id; | |
10216 | New_Stmts : constant List_Id := Empty_List; | |
10217 | ||
10218 | begin | |
10219 | Local_Proc := | |
10220 | Make_Defining_Identifier (Loc, | |
10221 | Chars => New_Internal_Name ('P')); | |
10222 | ||
10223 | Local_Body := | |
10224 | Make_Subprogram_Body (Loc, | |
10225 | Specification => | |
10226 | Make_Procedure_Specification (Loc, | |
10227 | Defining_Unit_Name => Local_Proc), | |
10228 | Declarations => Empty_List, | |
10229 | Handled_Statement_Sequence => | |
10230 | Make_Handled_Sequence_Of_Statements (Loc, | |
10231 | Statements => Stmts)); | |
10232 | ||
10233 | Append_To (New_Stmts, Local_Body); | |
10234 | ||
10235 | Analyze (Local_Body); | |
10236 | ||
10237 | Set_Has_Nested_Subprogram (Local_Proc); | |
10238 | ||
10239 | Local_Call := | |
10240 | Make_Procedure_Call_Statement (Loc, | |
10241 | Name => New_Occurrence_Of (Local_Proc, Loc)); | |
10242 | ||
10243 | Append_To (New_Stmts, Local_Call); | |
10244 | Analyze (Local_Call); | |
10245 | ||
10246 | -- Traverse the statements, and for any that are declarations or | |
10247 | -- subprogram bodies that have entities, set the Scope of those | |
10248 | -- entities to the new procedure's Entity_Id. | |
10249 | ||
10250 | declare | |
10251 | Stmt : Node_Id := First (Stmts); | |
10252 | ||
10253 | begin | |
10254 | while Present (Stmt) loop | |
10255 | case Nkind (Stmt) is | |
10256 | when N_Declaration | |
10257 | | N_Renaming_Declaration | |
10258 | => | |
10259 | Set_Scope (Defining_Identifier (Stmt), Local_Proc); | |
10260 | ||
10261 | when N_Subprogram_Body => | |
10262 | Set_Scope | |
10263 | (Defining_Unit_Name (Specification (Stmt)), Local_Proc); | |
10264 | ||
10265 | when others => | |
10266 | null; | |
10267 | end case; | |
10268 | ||
10269 | Next (Stmt); | |
10270 | end loop; | |
10271 | end; | |
10272 | ||
10273 | Stmts := New_Stmts; | |
10274 | end Unnest_Statement_List; | |
10275 | ||
70482933 RK |
10276 | -------------------------------- |
10277 | -- Wrap_Transient_Declaration -- | |
10278 | -------------------------------- | |
10279 | ||
10280 | -- If a transient scope has been established during the processing of the | |
10281 | -- Expression of an Object_Declaration, it is not possible to wrap the | |
10282 | -- declaration into a transient block as usual case, otherwise the object | |
10283 | -- would be itself declared in the wrong scope. Therefore, all entities (if | |
10284 | -- any) defined in the transient block are moved to the proper enclosing | |
8071b771 | 10285 | -- scope. Furthermore, if they are controlled variables they are finalized |
70482933 RK |
10286 | -- right after the declaration. The finalization list of the transient |
10287 | -- scope is defined as a renaming of the enclosing one so during their | |
cfae2bed AC |
10288 | -- initialization they will be attached to the proper finalization list. |
10289 | -- For instance, the following declaration : | |
70482933 RK |
10290 | |
10291 | -- X : Typ := F (G (A), G (B)); | |
10292 | ||
10293 | -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) | |
10294 | -- is expanded into : | |
10295 | ||
70482933 | 10296 | -- X : Typ := [ complex Expression-Action ]; |
df3e68b1 HK |
10297 | -- [Deep_]Finalize (_v1); |
10298 | -- [Deep_]Finalize (_v2); | |
70482933 RK |
10299 | |
10300 | procedure Wrap_Transient_Declaration (N : Node_Id) is | |
8e888920 AC |
10301 | Curr_S : Entity_Id; |
10302 | Encl_S : Entity_Id; | |
23685ae6 | 10303 | |
70482933 | 10304 | begin |
8e888920 AC |
10305 | Curr_S := Current_Scope; |
10306 | Encl_S := Scope (Curr_S); | |
10307 | ||
57d3adcd | 10308 | -- Insert all actions including cleanup generated while analyzing or |
8e888920 AC |
10309 | -- expanding the transient context back into the tree. Manage the |
10310 | -- secondary stack when the object declaration appears in a library | |
57d3adcd | 10311 | -- level package [body]. |
8e888920 AC |
10312 | |
10313 | Insert_Actions_In_Scope_Around | |
10314 | (N => N, | |
10315 | Clean => True, | |
10316 | Manage_SS => | |
535a8637 | 10317 | Uses_Sec_Stack (Curr_S) |
8e888920 | 10318 | and then Nkind (N) = N_Object_Declaration |
4a08c95c | 10319 | and then Ekind (Encl_S) in E_Package | E_Package_Body |
8e888920 | 10320 | and then Is_Library_Level_Entity (Encl_S)); |
70482933 RK |
10321 | Pop_Scope; |
10322 | ||
8e888920 AC |
10323 | -- Relocate local entities declared within the transient scope to the |
10324 | -- enclosing scope. This action sets their Is_Public flag accordingly. | |
10325 | ||
10326 | Transfer_Entities (Curr_S, Encl_S); | |
70482933 | 10327 | |
8e888920 | 10328 | -- Mark the enclosing dynamic scope to ensure that the secondary stack |
535a8637 | 10329 | -- is properly released upon exiting the said scope. |
70482933 | 10330 | |
535a8637 | 10331 | if Uses_Sec_Stack (Curr_S) then |
8e888920 | 10332 | Curr_S := Enclosing_Dynamic_Scope (Curr_S); |
70482933 | 10333 | |
8e888920 AC |
10334 | -- Do not mark a function that returns on the secondary stack as the |
10335 | -- reclamation is done by the caller. | |
70482933 | 10336 | |
8e888920 AC |
10337 | if Ekind (Curr_S) = E_Function |
10338 | and then Requires_Transient_Scope (Etype (Curr_S)) | |
70482933 RK |
10339 | then |
10340 | null; | |
8e888920 AC |
10341 | |
10342 | -- Otherwise mark the enclosing dynamic scope | |
10343 | ||
70482933 | 10344 | else |
8e888920 | 10345 | Set_Uses_Sec_Stack (Curr_S); |
17c5c8a5 | 10346 | Check_Restriction (No_Secondary_Stack, N); |
70482933 RK |
10347 | end if; |
10348 | end if; | |
10349 | end Wrap_Transient_Declaration; | |
10350 | ||
10351 | ------------------------------- | |
10352 | -- Wrap_Transient_Expression -- | |
10353 | ------------------------------- | |
10354 | ||
70482933 | 10355 | procedure Wrap_Transient_Expression (N : Node_Id) is |
df3e68b1 | 10356 | Loc : constant Source_Ptr := Sloc (N); |
d8a764c4 | 10357 | Expr : Node_Id := Relocate_Node (N); |
df3e68b1 HK |
10358 | Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N); |
10359 | Typ : constant Entity_Id := Etype (N); | |
70482933 RK |
10360 | |
10361 | begin | |
df3e68b1 | 10362 | -- Generate: |
cfae2bed | 10363 | |
df3e68b1 HK |
10364 | -- Temp : Typ; |
10365 | -- declare | |
10366 | -- M : constant Mark_Id := SS_Mark; | |
10367 | -- procedure Finalizer is ... (See Build_Finalizer) | |
41c79d60 | 10368 | |
df3e68b1 | 10369 | -- begin |
d8a764c4 AC |
10370 | -- Temp := <Expr>; -- general case |
10371 | -- Temp := (if <Expr> then True else False); -- boolean case | |
41c79d60 | 10372 | |
df3e68b1 HK |
10373 | -- at end |
10374 | -- Finalizer; | |
10375 | -- end; | |
10376 | ||
40c21e91 | 10377 | -- A special case is made for Boolean expressions so that the back end |
061828e3 | 10378 | -- knows to generate a conditional branch instruction, if running with |
40c21e91 PMR |
10379 | -- -fpreserve-control-flow. This ensures that a control-flow change |
10380 | -- signaling the decision outcome occurs before the cleanup actions. | |
d8a764c4 | 10381 | |
061828e3 | 10382 | if Opt.Suppress_Control_Flow_Optimizations |
7dbd3de9 | 10383 | and then Is_Boolean_Type (Typ) |
061828e3 | 10384 | then |
4058ddcc AC |
10385 | Expr := |
10386 | Make_If_Expression (Loc, | |
10387 | Expressions => New_List ( | |
10388 | Expr, | |
10389 | New_Occurrence_Of (Standard_True, Loc), | |
10390 | New_Occurrence_Of (Standard_False, Loc))); | |
d8a764c4 AC |
10391 | end if; |
10392 | ||
70482933 RK |
10393 | Insert_Actions (N, New_List ( |
10394 | Make_Object_Declaration (Loc, | |
df3e68b1 | 10395 | Defining_Identifier => Temp, |
e4494292 | 10396 | Object_Definition => New_Occurrence_Of (Typ, Loc)), |
70482933 RK |
10397 | |
10398 | Make_Transient_Block (Loc, | |
10399 | Action => | |
10400 | Make_Assignment_Statement (Loc, | |
e4494292 | 10401 | Name => New_Occurrence_Of (Temp, Loc), |
df3e68b1 | 10402 | Expression => Expr), |
2c1b72d7 | 10403 | Par => Parent (N)))); |
70482933 | 10404 | |
bbf14e13 AC |
10405 | if Debug_Generated_Code then |
10406 | Set_Debug_Info_Needed (Temp); | |
10407 | end if; | |
10408 | ||
e4494292 | 10409 | Rewrite (N, New_Occurrence_Of (Temp, Loc)); |
df3e68b1 | 10410 | Analyze_And_Resolve (N, Typ); |
70482933 RK |
10411 | end Wrap_Transient_Expression; |
10412 | ||
10413 | ------------------------------ | |
10414 | -- Wrap_Transient_Statement -- | |
10415 | ------------------------------ | |
10416 | ||
70482933 | 10417 | procedure Wrap_Transient_Statement (N : Node_Id) is |
df3e68b1 HK |
10418 | Loc : constant Source_Ptr := Sloc (N); |
10419 | New_Stmt : constant Node_Id := Relocate_Node (N); | |
70482933 RK |
10420 | |
10421 | begin | |
df3e68b1 HK |
10422 | -- Generate: |
10423 | -- declare | |
10424 | -- M : constant Mark_Id := SS_Mark; | |
10425 | -- procedure Finalizer is ... (See Build_Finalizer) | |
10426 | -- | |
10427 | -- begin | |
10428 | -- <New_Stmt>; | |
10429 | -- | |
10430 | -- at end | |
10431 | -- Finalizer; | |
10432 | -- end; | |
10433 | ||
10434 | Rewrite (N, | |
10435 | Make_Transient_Block (Loc, | |
10436 | Action => New_Stmt, | |
10437 | Par => Parent (N))); | |
70482933 RK |
10438 | |
10439 | -- With the scope stack back to normal, we can call analyze on the | |
10440 | -- resulting block. At this point, the transient scope is being | |
10441 | -- treated like a perfectly normal scope, so there is nothing | |
10442 | -- special about it. | |
10443 | ||
10444 | -- Note: Wrap_Transient_Statement is called with the node already | |
10445 | -- analyzed (i.e. Analyzed (N) is True). This is important, since | |
10446 | -- otherwise we would get a recursive processing of the node when | |
10447 | -- we do this Analyze call. | |
10448 | ||
10449 | Analyze (N); | |
10450 | end Wrap_Transient_Statement; | |
10451 | ||
10452 | end Exp_Ch7; |