]>
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 | -- -- | |
7665e4bd | 9 | -- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- |
70482933 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | -- This package contains virtually all expansion mechanisms related to | |
27 | -- - controlled types | |
28 | -- - transient scopes | |
29 | ||
30 | with Atree; use Atree; | |
31 | with Debug; use Debug; | |
32 | with Einfo; use Einfo; | |
fbf5a39b | 33 | with Errout; use Errout; |
70482933 RK |
34 | with Exp_Ch9; use Exp_Ch9; |
35 | with Exp_Ch11; use Exp_Ch11; | |
36 | with Exp_Dbug; use Exp_Dbug; | |
afe4375b | 37 | with Exp_Dist; use Exp_Dist; |
33c423c8 | 38 | with Exp_Disp; use Exp_Disp; |
70482933 RK |
39 | with Exp_Tss; use Exp_Tss; |
40 | with Exp_Util; use Exp_Util; | |
41 | with Freeze; use Freeze; | |
afe4375b | 42 | with Lib; use Lib; |
70482933 RK |
43 | with Nlists; use Nlists; |
44 | with Nmake; use Nmake; | |
45 | with Opt; use Opt; | |
46 | with Output; use Output; | |
47 | with Restrict; use Restrict; | |
6e937c1c | 48 | with Rident; use Rident; |
70482933 | 49 | with Rtsfind; use Rtsfind; |
70482933 RK |
50 | with Sinfo; use Sinfo; |
51 | with Sem; use Sem; | |
a4100e55 | 52 | with Sem_Aux; use Sem_Aux; |
70482933 RK |
53 | with Sem_Ch3; use Sem_Ch3; |
54 | with Sem_Ch7; use Sem_Ch7; | |
55 | with Sem_Ch8; use Sem_Ch8; | |
56 | with Sem_Res; use Sem_Res; | |
57 | with Sem_Type; use Sem_Type; | |
58 | with Sem_Util; use Sem_Util; | |
59 | with Snames; use Snames; | |
60 | with Stand; use Stand; | |
dbe13a37 | 61 | with Targparm; use Targparm; |
70482933 RK |
62 | with Tbuild; use Tbuild; |
63 | with Uintp; use Uintp; | |
64 | ||
65 | package body Exp_Ch7 is | |
66 | ||
67 | -------------------------------- | |
68 | -- Transient Scope Management -- | |
69 | -------------------------------- | |
70 | ||
71 | -- A transient scope is created when temporary objects are created by the | |
72 | -- compiler. These temporary objects are allocated on the secondary stack | |
73 | -- and the transient scope is responsible for finalizing the object when | |
74 | -- appropriate and reclaiming the memory at the right time. The temporary | |
75 | -- objects are generally the objects allocated to store the result of a | |
76 | -- function returning an unconstrained or a tagged value. Expressions | |
77 | -- needing to be wrapped in a transient scope (functions calls returning | |
78 | -- unconstrained or tagged values) may appear in 3 different contexts which | |
79 | -- lead to 3 different kinds of transient scope expansion: | |
80 | ||
81 | -- 1. In a simple statement (procedure call, assignment, ...). In | |
82 | -- this case the instruction is wrapped into a transient block. | |
83 | -- (See Wrap_Transient_Statement for details) | |
84 | ||
85 | -- 2. In an expression of a control structure (test in a IF statement, | |
86 | -- expression in a CASE statement, ...). | |
87 | -- (See Wrap_Transient_Expression for details) | |
88 | ||
89 | -- 3. In a expression of an object_declaration. No wrapping is possible | |
36c73552 | 90 | -- here, so the finalization actions, if any, are done right after the |
70482933 RK |
91 | -- declaration and the secondary stack deallocation is done in the |
92 | -- proper enclosing scope (see Wrap_Transient_Declaration for details) | |
93 | ||
36c73552 | 94 | -- Note about functions returning tagged types: it has been decided to |
dbe13a37 | 95 | -- always allocate their result in the secondary stack, even though is not |
70482933 RK |
96 | -- absolutely mandatory when the tagged type is constrained because the |
97 | -- caller knows the size of the returned object and thus could allocate the | |
dbe13a37 ES |
98 | -- result in the primary stack. An exception to this is when the function |
99 | -- builds its result in place, as is done for functions with inherently | |
100 | -- limited result types for Ada 2005. In that case, certain callers may | |
101 | -- pass the address of a constrained object as the target object for the | |
102 | -- function result. | |
70482933 | 103 | |
dbe13a37 ES |
104 | -- By allocating tagged results in the secondary stack a number of |
105 | -- implementation difficulties are avoided: | |
106 | ||
107 | -- - If it is a dispatching function call, the computation of the size of | |
70482933 RK |
108 | -- the result is possible but complex from the outside. |
109 | ||
110 | -- - If the returned type is controlled, the assignment of the returned | |
111 | -- value to the anonymous object involves an Adjust, and we have no | |
dbe13a37 | 112 | -- easy way to access the anonymous object created by the back end. |
70482933 RK |
113 | |
114 | -- - If the returned type is class-wide, this is an unconstrained type | |
dbe13a37 | 115 | -- anyway. |
70482933 | 116 | |
dbe13a37 ES |
117 | -- Furthermore, the small loss in efficiency which is the result of this |
118 | -- decision is not such a big deal because functions returning tagged types | |
119 | -- are not as common in practice compared to functions returning access to | |
120 | -- a tagged type. | |
70482933 RK |
121 | |
122 | -------------------------------------------------- | |
123 | -- Transient Blocks and Finalization Management -- | |
124 | -------------------------------------------------- | |
125 | ||
126 | function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; | |
36c73552 AC |
127 | -- N is a node which may generate a transient scope. Loop over the parent |
128 | -- pointers of N until it find the appropriate node to wrap. If it returns | |
129 | -- Empty, it means that no transient scope is needed in this context. | |
70482933 RK |
130 | |
131 | function Make_Clean | |
132 | (N : Node_Id; | |
133 | Clean : Entity_Id; | |
134 | Mark : Entity_Id; | |
135 | Flist : Entity_Id; | |
136 | Is_Task : Boolean; | |
137 | Is_Master : Boolean; | |
138 | Is_Protected_Subprogram : Boolean; | |
139 | Is_Task_Allocation_Block : Boolean; | |
dcfa065d GD |
140 | Is_Asynchronous_Call_Block : Boolean; |
141 | Chained_Cleanup_Action : Node_Id) return Node_Id; | |
142 | -- Expand the clean-up procedure for a controlled and/or transient block, | |
143 | -- and/or task master or task body, or a block used to implement task | |
144 | -- allocation or asynchronous entry calls, or a procedure used to implement | |
145 | -- protected procedures. Clean is the entity for such a procedure. Mark | |
146 | -- is the entity for the secondary stack mark, if empty only controlled | |
147 | -- block clean-up will be performed. Flist is the entity for the local | |
148 | -- final list, if empty only transient scope clean-up will be performed. | |
149 | -- The flags Is_Task and Is_Master control the calls to the corresponding | |
150 | -- finalization actions for a task body or for an entity that is a task | |
151 | -- master. Finally if Chained_Cleanup_Action is present, it is a reference | |
152 | -- to a previous cleanup procedure, a call to which is appended at the | |
153 | -- end of the generated one. | |
70482933 RK |
154 | |
155 | procedure Set_Node_To_Be_Wrapped (N : Node_Id); | |
156 | -- Set the field Node_To_Be_Wrapped of the current scope | |
157 | ||
158 | procedure Insert_Actions_In_Scope_Around (N : Node_Id); | |
159 | -- Insert the before-actions kept in the scope stack before N, and the | |
36c73552 | 160 | -- after-actions after N, which must be a member of a list. |
70482933 RK |
161 | |
162 | function Make_Transient_Block | |
163 | (Loc : Source_Ptr; | |
15ce9ca2 | 164 | Action : Node_Id) return Node_Id; |
36c73552 AC |
165 | -- Create a transient block whose name is Scope, which is also a controlled |
166 | -- block if Flist is not empty and whose only code is Action (either a | |
167 | -- single statement or single declaration). | |
70482933 RK |
168 | |
169 | type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case); | |
170 | -- This enumeration type is defined in order to ease sharing code for | |
171 | -- building finalization procedures for composite types. | |
172 | ||
173 | Name_Of : constant array (Final_Primitives) of Name_Id := | |
174 | (Initialize_Case => Name_Initialize, | |
175 | Adjust_Case => Name_Adjust, | |
176 | Finalize_Case => Name_Finalize); | |
177 | ||
fbf5a39b AC |
178 | Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type := |
179 | (Initialize_Case => TSS_Deep_Initialize, | |
180 | Adjust_Case => TSS_Deep_Adjust, | |
181 | Finalize_Case => TSS_Deep_Finalize); | |
70482933 RK |
182 | |
183 | procedure Build_Record_Deep_Procs (Typ : Entity_Id); | |
184 | -- Build the deep Initialize/Adjust/Finalize for a record Typ with | |
185 | -- Has_Component_Component set and store them using the TSS mechanism. | |
186 | ||
187 | procedure Build_Array_Deep_Procs (Typ : Entity_Id); | |
188 | -- Build the deep Initialize/Adjust/Finalize for a record Typ with | |
189 | -- Has_Controlled_Component set and store them using the TSS mechanism. | |
190 | ||
191 | function Make_Deep_Proc | |
192 | (Prim : Final_Primitives; | |
193 | Typ : Entity_Id; | |
15ce9ca2 | 194 | Stmts : List_Id) return Node_Id; |
36c73552 AC |
195 | -- This function generates the tree for Deep_Initialize, Deep_Adjust or |
196 | -- Deep_Finalize procedures according to the first parameter, these | |
197 | -- procedures operate on the type Typ. The Stmts parameter gives the body | |
198 | -- of the procedure. | |
70482933 RK |
199 | |
200 | function Make_Deep_Array_Body | |
201 | (Prim : Final_Primitives; | |
15ce9ca2 | 202 | Typ : Entity_Id) return List_Id; |
70482933 | 203 | -- This function generates the list of statements for implementing |
36c73552 AC |
204 | -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to |
205 | -- the first parameter, these procedures operate on the array type Typ. | |
70482933 RK |
206 | |
207 | function Make_Deep_Record_Body | |
208 | (Prim : Final_Primitives; | |
15ce9ca2 | 209 | Typ : Entity_Id) return List_Id; |
70482933 | 210 | -- This function generates the list of statements for implementing |
36c73552 AC |
211 | -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to |
212 | -- the first parameter, these procedures operate on the record type Typ. | |
70482933 | 213 | |
fbf5a39b AC |
214 | procedure Check_Visibly_Controlled |
215 | (Prim : Final_Primitives; | |
216 | Typ : Entity_Id; | |
217 | E : in out Entity_Id; | |
218 | Cref : in out Node_Id); | |
219 | -- The controlled operation declared for a derived type may not be | |
220 | -- overriding, if the controlled operations of the parent type are | |
221 | -- hidden, for example when the parent is a private type whose full | |
222 | -- view is controlled. For other primitive operations we modify the | |
223 | -- name of the operation to indicate that it is not overriding, but | |
224 | -- this is not possible for Initialize, etc. because they have to be | |
225 | -- retrievable by name. Before generating the proper call to one of | |
226 | -- these operations we check whether Typ is known to be controlled at | |
227 | -- the point of definition. If it is not then we must retrieve the | |
228 | -- hidden operation of the parent and use it instead. This is one | |
229 | -- case that might be solved more cleanly once Overriding pragmas or | |
230 | -- declarations are in place. | |
231 | ||
70482933 RK |
232 | function Convert_View |
233 | (Proc : Entity_Id; | |
234 | Arg : Node_Id; | |
15ce9ca2 | 235 | Ind : Pos := 1) return Node_Id; |
70482933 RK |
236 | -- Proc is one of the Initialize/Adjust/Finalize operations, and |
237 | -- Arg is the argument being passed to it. Ind indicates which | |
238 | -- formal of procedure Proc we are trying to match. This function | |
239 | -- will, if necessary, generate an conversion between the partial | |
240 | -- and full view of Arg to match the type of the formal of Proc, | |
241 | -- or force a conversion to the class-wide type in the case where | |
242 | -- the operation is abstract. | |
243 | ||
244 | ----------------------------- | |
245 | -- Finalization Management -- | |
246 | ----------------------------- | |
247 | ||
8fc789c8 | 248 | -- This part describe how Initialization/Adjustment/Finalization procedures |
70482933 RK |
249 | -- are generated and called. Two cases must be considered, types that are |
250 | -- Controlled (Is_Controlled flag set) and composite types that contain | |
251 | -- controlled components (Has_Controlled_Component flag set). In the first | |
252 | -- case the procedures to call are the user-defined primitive operations | |
253 | -- Initialize/Adjust/Finalize. In the second case, GNAT generates | |
dbe13a37 ES |
254 | -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge |
255 | -- of calling the former procedures on the controlled components. | |
70482933 RK |
256 | |
257 | -- For records with Has_Controlled_Component set, a hidden "controller" | |
258 | -- component is inserted. This controller component contains its own | |
259 | -- finalization list on which all controlled components are attached | |
260 | -- creating an indirection on the upper-level Finalization list. This | |
261 | -- technique facilitates the management of objects whose number of | |
262 | -- controlled components changes during execution. This controller | |
263 | -- component is itself controlled and is attached to the upper-level | |
dbe13a37 | 264 | -- finalization chain. Its adjust primitive is in charge of calling adjust |
8fc789c8 | 265 | -- on the components and adjusting the finalization pointer to match their |
dbe13a37 | 266 | -- new location (see a-finali.adb). |
70482933 RK |
267 | |
268 | -- It is not possible to use a similar technique for arrays that have | |
269 | -- Has_Controlled_Component set. In this case, deep procedures are | |
270 | -- generated that call initialize/adjust/finalize + attachment or | |
271 | -- detachment on the finalization list for all component. | |
272 | ||
273 | -- Initialize calls: they are generated for declarations or dynamic | |
dbe13a37 ES |
274 | -- allocations of Controlled objects with no initial value. They are always |
275 | -- followed by an attachment to the current Finalization Chain. For the | |
276 | -- dynamic allocation case this the chain attached to the scope of the | |
277 | -- access type definition otherwise, this is the chain of the current | |
278 | -- scope. | |
70482933 RK |
279 | |
280 | -- Adjust Calls: They are generated on 2 occasions: (1) for | |
281 | -- declarations or dynamic allocations of Controlled objects with an | |
282 | -- initial value. (2) after an assignment. In the first case they are | |
283 | -- followed by an attachment to the final chain, in the second case | |
284 | -- they are not. | |
285 | ||
286 | -- Finalization Calls: They are generated on (1) scope exit, (2) | |
287 | -- assignments, (3) unchecked deallocations. In case (3) they have to | |
288 | -- be detached from the final chain, in case (2) they must not and in | |
dbe13a37 | 289 | -- case (1) this is not important since we are exiting the scope anyway. |
70482933 | 290 | |
fbf5a39b | 291 | -- Other details: |
dbe13a37 ES |
292 | |
293 | -- Type extensions will have a new record controller at each derivation | |
294 | -- level containing controlled components. The record controller for | |
295 | -- the parent/ancestor is attached to the finalization list of the | |
296 | -- extension's record controller (i.e. the parent is like a component | |
297 | -- of the extension). | |
298 | ||
299 | -- For types that are both Is_Controlled and Has_Controlled_Components, | |
300 | -- the record controller and the object itself are handled separately. | |
301 | -- It could seem simpler to attach the object at the end of its record | |
302 | -- controller but this would not tackle view conversions properly. | |
303 | ||
304 | -- A classwide type can always potentially have controlled components | |
305 | -- but the record controller of the corresponding actual type may not | |
306 | -- be known at compile time so the dispatch table contains a special | |
307 | -- field that allows to compute the offset of the record controller | |
308 | -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. | |
fbf5a39b | 309 | |
70482933 RK |
310 | -- Here is a simple example of the expansion of a controlled block : |
311 | ||
312 | -- declare | |
33c423c8 | 313 | -- X : Controlled; |
70482933 RK |
314 | -- Y : Controlled := Init; |
315 | -- | |
316 | -- type R is record | |
317 | -- C : Controlled; | |
318 | -- end record; | |
319 | -- W : R; | |
320 | -- Z : R := (C => X); | |
321 | -- begin | |
322 | -- X := Y; | |
323 | -- W := Z; | |
324 | -- end; | |
325 | -- | |
326 | -- is expanded into | |
327 | -- | |
328 | -- declare | |
329 | -- _L : System.FI.Finalizable_Ptr; | |
330 | ||
331 | -- procedure _Clean is | |
332 | -- begin | |
333 | -- Abort_Defer; | |
334 | -- System.FI.Finalize_List (_L); | |
335 | -- Abort_Undefer; | |
336 | -- end _Clean; | |
337 | ||
338 | -- X : Controlled; | |
fbf5a39b AC |
339 | -- begin |
340 | -- Abort_Defer; | |
341 | -- Initialize (X); | |
342 | -- Attach_To_Final_List (_L, Finalizable (X), 1); | |
343 | -- at end: Abort_Undefer; | |
70482933 RK |
344 | -- Y : Controlled := Init; |
345 | -- Adjust (Y); | |
346 | -- Attach_To_Final_List (_L, Finalizable (Y), 1); | |
347 | -- | |
348 | -- type R is record | |
349 | -- _C : Record_Controller; | |
350 | -- C : Controlled; | |
351 | -- end record; | |
352 | -- W : R; | |
fbf5a39b AC |
353 | -- begin |
354 | -- Abort_Defer; | |
355 | -- Deep_Initialize (W, _L, 1); | |
356 | -- at end: Abort_Under; | |
70482933 RK |
357 | -- Z : R := (C => X); |
358 | -- Deep_Adjust (Z, _L, 1); | |
359 | ||
360 | -- begin | |
fbf5a39b | 361 | -- _Assign (X, Y); |
70482933 | 362 | -- Deep_Finalize (W, False); |
fbf5a39b | 363 | -- <save W's final pointers> |
70482933 | 364 | -- W := Z; |
fbf5a39b | 365 | -- <restore W's final pointers> |
70482933 RK |
366 | -- Deep_Adjust (W, _L, 0); |
367 | -- at end | |
368 | -- _Clean; | |
369 | -- end; | |
370 | ||
371 | function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean; | |
33c423c8 AC |
372 | -- Return True if Flist_Ref refers to a global final list, either the |
373 | -- object Global_Final_List which is used to attach standalone objects, | |
374 | -- or any of the list controllers associated with library-level access | |
375 | -- to controlled objects. | |
70482933 | 376 | |
fbf5a39b AC |
377 | procedure Clean_Simple_Protected_Objects (N : Node_Id); |
378 | -- Protected objects without entries are not controlled types, and the | |
379 | -- locks have to be released explicitly when such an object goes out | |
380 | -- of scope. Traverse declarations in scope to determine whether such | |
381 | -- objects are present. | |
382 | ||
70482933 RK |
383 | ---------------------------- |
384 | -- Build_Array_Deep_Procs -- | |
385 | ---------------------------- | |
386 | ||
387 | procedure Build_Array_Deep_Procs (Typ : Entity_Id) is | |
388 | begin | |
389 | Set_TSS (Typ, | |
390 | Make_Deep_Proc ( | |
391 | Prim => Initialize_Case, | |
392 | Typ => Typ, | |
393 | Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); | |
394 | ||
40f07b4b | 395 | if not Is_Immutably_Limited_Type (Typ) then |
70482933 RK |
396 | Set_TSS (Typ, |
397 | Make_Deep_Proc ( | |
398 | Prim => Adjust_Case, | |
399 | Typ => Typ, | |
400 | Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); | |
401 | end if; | |
402 | ||
403 | Set_TSS (Typ, | |
404 | Make_Deep_Proc ( | |
405 | Prim => Finalize_Case, | |
406 | Typ => Typ, | |
407 | Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); | |
408 | end Build_Array_Deep_Procs; | |
409 | ||
410 | ----------------------------- | |
411 | -- Build_Controlling_Procs -- | |
412 | ----------------------------- | |
413 | ||
414 | procedure Build_Controlling_Procs (Typ : Entity_Id) is | |
415 | begin | |
416 | if Is_Array_Type (Typ) then | |
417 | Build_Array_Deep_Procs (Typ); | |
418 | ||
419 | else pragma Assert (Is_Record_Type (Typ)); | |
420 | Build_Record_Deep_Procs (Typ); | |
421 | end if; | |
422 | end Build_Controlling_Procs; | |
423 | ||
424 | ---------------------- | |
425 | -- Build_Final_List -- | |
426 | ---------------------- | |
427 | ||
428 | procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is | |
07fc65c4 GB |
429 | Loc : constant Source_Ptr := Sloc (N); |
430 | Decl : Node_Id; | |
70482933 RK |
431 | |
432 | begin | |
433 | Set_Associated_Final_Chain (Typ, | |
434 | Make_Defining_Identifier (Loc, | |
435 | New_External_Name (Chars (Typ), 'L'))); | |
436 | ||
07fc65c4 | 437 | Decl := |
70482933 RK |
438 | Make_Object_Declaration (Loc, |
439 | Defining_Identifier => | |
440 | Associated_Final_Chain (Typ), | |
441 | Object_Definition => | |
442 | New_Reference_To | |
07fc65c4 GB |
443 | (RTE (RE_List_Controller), Loc)); |
444 | ||
b603e37b AC |
445 | -- If the type is declared in a package declaration and designates a |
446 | -- Taft amendment type that requires finalization, place declaration | |
811c6a85 AC |
447 | -- of finalization list in the body, because no client of the package |
448 | -- can create objects of the type and thus make use of this list. This | |
449 | -- ensures the tree for the spec is identical whenever it is compiled. | |
b603e37b | 450 | |
66713d62 AC |
451 | if Has_Completion_In_Body (Directly_Designated_Type (Typ)) |
452 | and then In_Package_Body (Current_Scope) | |
4f87ded3 | 453 | and then Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body |
66713d62 AC |
454 | and then |
455 | Nkind (Parent (Declaration_Node (Typ))) = N_Package_Specification | |
456 | then | |
b603e37b | 457 | Insert_Action (Parent (Designated_Type (Typ)), Decl); |
66713d62 | 458 | |
fbf5a39b AC |
459 | -- The type may have been frozen already, and this is a late freezing |
460 | -- action, in which case the declaration must be elaborated at once. | |
461 | -- If the call is for an allocator, the chain must also be created now, | |
462 | -- because the freezing of the type does not build one. Otherwise, the | |
463 | -- declaration is one of the freezing actions for a user-defined type. | |
07fc65c4 | 464 | |
b603e37b | 465 | elsif Is_Frozen (Typ) |
07fc65c4 GB |
466 | or else (Nkind (N) = N_Allocator |
467 | and then Ekind (Etype (N)) = E_Anonymous_Access_Type) | |
468 | then | |
469 | Insert_Action (N, Decl); | |
b603e37b | 470 | |
07fc65c4 GB |
471 | else |
472 | Append_Freeze_Action (Typ, Decl); | |
473 | end if; | |
70482933 RK |
474 | end Build_Final_List; |
475 | ||
07fc65c4 GB |
476 | --------------------- |
477 | -- Build_Late_Proc -- | |
478 | --------------------- | |
479 | ||
480 | procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is | |
481 | begin | |
482 | for Final_Prim in Name_Of'Range loop | |
483 | if Name_Of (Final_Prim) = Nam then | |
484 | Set_TSS (Typ, | |
485 | Make_Deep_Proc ( | |
486 | Prim => Final_Prim, | |
487 | Typ => Typ, | |
488 | Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); | |
489 | end if; | |
490 | end loop; | |
491 | end Build_Late_Proc; | |
492 | ||
70482933 RK |
493 | ----------------------------- |
494 | -- Build_Record_Deep_Procs -- | |
495 | ----------------------------- | |
496 | ||
497 | procedure Build_Record_Deep_Procs (Typ : Entity_Id) is | |
498 | begin | |
499 | Set_TSS (Typ, | |
500 | Make_Deep_Proc ( | |
501 | Prim => Initialize_Case, | |
502 | Typ => Typ, | |
503 | Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); | |
504 | ||
40f07b4b | 505 | if not Is_Immutably_Limited_Type (Typ) then |
70482933 RK |
506 | Set_TSS (Typ, |
507 | Make_Deep_Proc ( | |
508 | Prim => Adjust_Case, | |
509 | Typ => Typ, | |
510 | Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); | |
511 | end if; | |
512 | ||
513 | Set_TSS (Typ, | |
514 | Make_Deep_Proc ( | |
515 | Prim => Finalize_Case, | |
516 | Typ => Typ, | |
517 | Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); | |
518 | end Build_Record_Deep_Procs; | |
519 | ||
fbf5a39b AC |
520 | ------------------- |
521 | -- Cleanup_Array -- | |
522 | ------------------- | |
523 | ||
524 | function Cleanup_Array | |
525 | (N : Node_Id; | |
526 | Obj : Node_Id; | |
15ce9ca2 | 527 | Typ : Entity_Id) return List_Id |
fbf5a39b AC |
528 | is |
529 | Loc : constant Source_Ptr := Sloc (N); | |
91b1417d | 530 | Index_List : constant List_Id := New_List; |
fbf5a39b AC |
531 | |
532 | function Free_Component return List_Id; | |
533 | -- Generate the code to finalize the task or protected subcomponents | |
534 | -- of a single component of the array. | |
535 | ||
536 | function Free_One_Dimension (Dim : Int) return List_Id; | |
14532762 | 537 | -- Generate a loop over one dimension of the array |
fbf5a39b AC |
538 | |
539 | -------------------- | |
540 | -- Free_Component -- | |
541 | -------------------- | |
542 | ||
543 | function Free_Component return List_Id is | |
544 | Stmts : List_Id := New_List; | |
545 | Tsk : Node_Id; | |
91b1417d | 546 | C_Typ : constant Entity_Id := Component_Type (Typ); |
fbf5a39b AC |
547 | |
548 | begin | |
549 | -- Component type is known to contain tasks or protected objects | |
550 | ||
551 | Tsk := | |
552 | Make_Indexed_Component (Loc, | |
553 | Prefix => Duplicate_Subexpr_No_Checks (Obj), | |
554 | Expressions => Index_List); | |
555 | ||
556 | Set_Etype (Tsk, C_Typ); | |
557 | ||
558 | if Is_Task_Type (C_Typ) then | |
559 | Append_To (Stmts, Cleanup_Task (N, Tsk)); | |
560 | ||
561 | elsif Is_Simple_Protected_Type (C_Typ) then | |
562 | Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); | |
563 | ||
564 | elsif Is_Record_Type (C_Typ) then | |
565 | Stmts := Cleanup_Record (N, Tsk, C_Typ); | |
566 | ||
567 | elsif Is_Array_Type (C_Typ) then | |
568 | Stmts := Cleanup_Array (N, Tsk, C_Typ); | |
569 | end if; | |
570 | ||
571 | return Stmts; | |
572 | end Free_Component; | |
573 | ||
574 | ------------------------ | |
575 | -- Free_One_Dimension -- | |
576 | ------------------------ | |
577 | ||
578 | function Free_One_Dimension (Dim : Int) return List_Id is | |
579 | Index : Entity_Id; | |
580 | ||
581 | begin | |
582 | if Dim > Number_Dimensions (Typ) then | |
583 | return Free_Component; | |
584 | ||
585 | -- Here we generate the required loop | |
586 | ||
587 | else | |
c12beea0 | 588 | Index := Make_Temporary (Loc, 'J'); |
fbf5a39b AC |
589 | Append (New_Reference_To (Index, Loc), Index_List); |
590 | ||
591 | return New_List ( | |
592 | Make_Implicit_Loop_Statement (N, | |
593 | Identifier => Empty, | |
594 | Iteration_Scheme => | |
595 | Make_Iteration_Scheme (Loc, | |
596 | Loop_Parameter_Specification => | |
597 | Make_Loop_Parameter_Specification (Loc, | |
598 | Defining_Identifier => Index, | |
599 | Discrete_Subtype_Definition => | |
600 | Make_Attribute_Reference (Loc, | |
601 | Prefix => Duplicate_Subexpr (Obj), | |
602 | Attribute_Name => Name_Range, | |
603 | Expressions => New_List ( | |
604 | Make_Integer_Literal (Loc, Dim))))), | |
605 | Statements => Free_One_Dimension (Dim + 1))); | |
606 | end if; | |
607 | end Free_One_Dimension; | |
608 | ||
609 | -- Start of processing for Cleanup_Array | |
610 | ||
611 | begin | |
612 | return Free_One_Dimension (1); | |
613 | end Cleanup_Array; | |
614 | ||
615 | -------------------- | |
616 | -- Cleanup_Record -- | |
617 | -------------------- | |
618 | ||
619 | function Cleanup_Record | |
620 | (N : Node_Id; | |
621 | Obj : Node_Id; | |
15ce9ca2 | 622 | Typ : Entity_Id) return List_Id |
fbf5a39b AC |
623 | is |
624 | Loc : constant Source_Ptr := Sloc (N); | |
625 | Tsk : Node_Id; | |
626 | Comp : Entity_Id; | |
91b1417d AC |
627 | Stmts : constant List_Id := New_List; |
628 | U_Typ : constant Entity_Id := Underlying_Type (Typ); | |
fbf5a39b AC |
629 | |
630 | begin | |
631 | if Has_Discriminants (U_Typ) | |
632 | and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration | |
633 | and then | |
634 | Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition | |
635 | and then | |
636 | Present | |
637 | (Variant_Part | |
638 | (Component_List (Type_Definition (Parent (U_Typ))))) | |
639 | then | |
640 | -- For now, do not attempt to free a component that may appear in | |
641 | -- a variant, and instead issue a warning. Doing this "properly" | |
642 | -- would require building a case statement and would be quite a | |
643 | -- mess. Note that the RM only requires that free "work" for the | |
644 | -- case of a task access value, so already we go way beyond this | |
645 | -- in that we deal with the array case and non-discriminated | |
646 | -- record cases. | |
647 | ||
648 | Error_Msg_N | |
649 | ("task/protected object in variant record will not be freed?", N); | |
650 | return New_List (Make_Null_Statement (Loc)); | |
651 | end if; | |
652 | ||
653 | Comp := First_Component (Typ); | |
654 | ||
655 | while Present (Comp) loop | |
656 | if Has_Task (Etype (Comp)) | |
657 | or else Has_Simple_Protected_Object (Etype (Comp)) | |
658 | then | |
659 | Tsk := | |
660 | Make_Selected_Component (Loc, | |
661 | Prefix => Duplicate_Subexpr_No_Checks (Obj), | |
662 | Selector_Name => New_Occurrence_Of (Comp, Loc)); | |
663 | Set_Etype (Tsk, Etype (Comp)); | |
664 | ||
665 | if Is_Task_Type (Etype (Comp)) then | |
666 | Append_To (Stmts, Cleanup_Task (N, Tsk)); | |
667 | ||
668 | elsif Is_Simple_Protected_Type (Etype (Comp)) then | |
669 | Append_To (Stmts, Cleanup_Protected_Object (N, Tsk)); | |
670 | ||
671 | elsif Is_Record_Type (Etype (Comp)) then | |
672 | ||
673 | -- Recurse, by generating the prefix of the argument to | |
674 | -- the eventual cleanup call. | |
675 | ||
676 | Append_List_To | |
677 | (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); | |
678 | ||
679 | elsif Is_Array_Type (Etype (Comp)) then | |
680 | Append_List_To | |
681 | (Stmts, Cleanup_Array (N, Tsk, Etype (Comp))); | |
682 | end if; | |
683 | end if; | |
684 | ||
685 | Next_Component (Comp); | |
686 | end loop; | |
687 | ||
688 | return Stmts; | |
689 | end Cleanup_Record; | |
690 | ||
15ce9ca2 AC |
691 | ------------------------------ |
692 | -- Cleanup_Protected_Object -- | |
693 | ------------------------------ | |
fbf5a39b AC |
694 | |
695 | function Cleanup_Protected_Object | |
15ce9ca2 AC |
696 | (N : Node_Id; |
697 | Ref : Node_Id) return Node_Id | |
fbf5a39b AC |
698 | is |
699 | Loc : constant Source_Ptr := Sloc (N); | |
700 | ||
701 | begin | |
702 | return | |
703 | Make_Procedure_Call_Statement (Loc, | |
704 | Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc), | |
705 | Parameter_Associations => New_List ( | |
706 | Concurrent_Ref (Ref))); | |
707 | end Cleanup_Protected_Object; | |
708 | ||
709 | ------------------------------------ | |
710 | -- Clean_Simple_Protected_Objects -- | |
711 | ------------------------------------ | |
712 | ||
713 | procedure Clean_Simple_Protected_Objects (N : Node_Id) is | |
91b1417d AC |
714 | Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N)); |
715 | Stmt : Node_Id := Last (Stmts); | |
fbf5a39b | 716 | E : Entity_Id; |
fbf5a39b AC |
717 | |
718 | begin | |
719 | E := First_Entity (Current_Scope); | |
fbf5a39b AC |
720 | while Present (E) loop |
721 | if (Ekind (E) = E_Variable | |
722 | or else Ekind (E) = E_Constant) | |
723 | and then Has_Simple_Protected_Object (Etype (E)) | |
724 | and then not Has_Task (Etype (E)) | |
9bc856dd | 725 | and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration |
fbf5a39b AC |
726 | then |
727 | declare | |
728 | Typ : constant Entity_Id := Etype (E); | |
729 | Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt)); | |
730 | ||
731 | begin | |
6a2e4f0b AC |
732 | -- If the current context is a function, the end of the |
733 | -- statement sequence is likely to be a return statement. | |
734 | -- The cleanup code must be executed before the return. | |
735 | ||
736 | if Ekind (Current_Scope) = E_Function | |
737 | and then Nkind (Stmt) = Sinfo.N_Return_Statement | |
738 | then | |
739 | Stmt := Prev (Stmt); | |
740 | end if; | |
741 | ||
fbf5a39b | 742 | if Is_Simple_Protected_Type (Typ) then |
6a2e4f0b | 743 | Insert_After (Stmt, Cleanup_Protected_Object (N, Ref)); |
fbf5a39b AC |
744 | |
745 | elsif Has_Simple_Protected_Object (Typ) then | |
746 | if Is_Record_Type (Typ) then | |
6a2e4f0b | 747 | Insert_List_After (Stmt, Cleanup_Record (N, Ref, Typ)); |
fbf5a39b AC |
748 | |
749 | elsif Is_Array_Type (Typ) then | |
6a2e4f0b | 750 | Insert_List_After (Stmt, Cleanup_Array (N, Ref, Typ)); |
fbf5a39b AC |
751 | end if; |
752 | end if; | |
753 | end; | |
754 | end if; | |
755 | ||
756 | Next_Entity (E); | |
757 | end loop; | |
758 | ||
14532762 | 759 | -- Analyze inserted cleanup statements |
fbf5a39b AC |
760 | |
761 | if Present (Stmt) then | |
762 | Stmt := Next (Stmt); | |
763 | ||
764 | while Present (Stmt) loop | |
765 | Analyze (Stmt); | |
766 | Next (Stmt); | |
767 | end loop; | |
768 | end if; | |
769 | end Clean_Simple_Protected_Objects; | |
770 | ||
771 | ------------------ | |
772 | -- Cleanup_Task -- | |
773 | ------------------ | |
774 | ||
775 | function Cleanup_Task | |
15ce9ca2 AC |
776 | (N : Node_Id; |
777 | Ref : Node_Id) return Node_Id | |
fbf5a39b AC |
778 | is |
779 | Loc : constant Source_Ptr := Sloc (N); | |
780 | begin | |
781 | return | |
782 | Make_Procedure_Call_Statement (Loc, | |
783 | Name => New_Reference_To (RTE (RE_Free_Task), Loc), | |
784 | Parameter_Associations => | |
785 | New_List (Concurrent_Ref (Ref))); | |
786 | end Cleanup_Task; | |
787 | ||
788 | --------------------------------- | |
789 | -- Has_Simple_Protected_Object -- | |
790 | --------------------------------- | |
791 | ||
792 | function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is | |
793 | Comp : Entity_Id; | |
794 | ||
795 | begin | |
796 | if Is_Simple_Protected_Type (T) then | |
797 | return True; | |
798 | ||
799 | elsif Is_Array_Type (T) then | |
800 | return Has_Simple_Protected_Object (Component_Type (T)); | |
801 | ||
802 | elsif Is_Record_Type (T) then | |
803 | Comp := First_Component (T); | |
804 | ||
805 | while Present (Comp) loop | |
806 | if Has_Simple_Protected_Object (Etype (Comp)) then | |
807 | return True; | |
808 | end if; | |
809 | ||
810 | Next_Component (Comp); | |
811 | end loop; | |
812 | ||
813 | return False; | |
814 | ||
815 | else | |
816 | return False; | |
817 | end if; | |
818 | end Has_Simple_Protected_Object; | |
819 | ||
820 | ------------------------------ | |
821 | -- Is_Simple_Protected_Type -- | |
822 | ------------------------------ | |
823 | ||
824 | function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is | |
825 | begin | |
826 | return Is_Protected_Type (T) and then not Has_Entries (T); | |
827 | end Is_Simple_Protected_Type; | |
828 | ||
829 | ------------------------------ | |
830 | -- Check_Visibly_Controlled -- | |
831 | ------------------------------ | |
832 | ||
833 | procedure Check_Visibly_Controlled | |
834 | (Prim : Final_Primitives; | |
835 | Typ : Entity_Id; | |
836 | E : in out Entity_Id; | |
837 | Cref : in out Node_Id) | |
838 | is | |
839 | Parent_Type : Entity_Id; | |
840 | Op : Entity_Id; | |
841 | ||
842 | begin | |
843 | if Is_Derived_Type (Typ) | |
844 | and then Comes_From_Source (E) | |
038140ed | 845 | and then not Present (Overridden_Operation (E)) |
fbf5a39b | 846 | then |
5950a3ac | 847 | -- We know that the explicit operation on the type does not override |
fbf5a39b AC |
848 | -- the inherited operation of the parent, and that the derivation |
849 | -- is from a private type that is not visibly controlled. | |
850 | ||
851 | Parent_Type := Etype (Typ); | |
852 | Op := Find_Prim_Op (Parent_Type, Name_Of (Prim)); | |
853 | ||
5950a3ac | 854 | if Present (Op) then |
fbf5a39b AC |
855 | E := Op; |
856 | ||
857 | -- Wrap the object to be initialized into the proper | |
858 | -- unchecked conversion, to be compatible with the operation | |
859 | -- to be called. | |
860 | ||
861 | if Nkind (Cref) = N_Unchecked_Type_Conversion then | |
862 | Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref)); | |
863 | else | |
864 | Cref := Unchecked_Convert_To (Parent_Type, Cref); | |
865 | end if; | |
866 | end if; | |
867 | end if; | |
868 | end Check_Visibly_Controlled; | |
869 | ||
048e5cef BD |
870 | ------------------------------- |
871 | -- CW_Or_Has_Controlled_Part -- | |
872 | ------------------------------- | |
afe4375b | 873 | |
048e5cef | 874 | function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is |
afe4375b | 875 | begin |
048e5cef BD |
876 | return Is_Class_Wide_Type (T) or else Needs_Finalization (T); |
877 | end CW_Or_Has_Controlled_Part; | |
afe4375b | 878 | |
70482933 RK |
879 | -------------------------- |
880 | -- Controller_Component -- | |
881 | -------------------------- | |
882 | ||
883 | function Controller_Component (Typ : Entity_Id) return Entity_Id is | |
884 | T : Entity_Id := Base_Type (Typ); | |
885 | Comp : Entity_Id; | |
886 | Comp_Scop : Entity_Id; | |
887 | Res : Entity_Id := Empty; | |
888 | Res_Scop : Entity_Id := Empty; | |
889 | ||
890 | begin | |
891 | if Is_Class_Wide_Type (T) then | |
892 | T := Root_Type (T); | |
893 | end if; | |
894 | ||
895 | if Is_Private_Type (T) then | |
896 | T := Underlying_Type (T); | |
897 | end if; | |
898 | ||
899 | -- Fetch the outermost controller | |
900 | ||
901 | Comp := First_Entity (T); | |
902 | while Present (Comp) loop | |
903 | if Chars (Comp) = Name_uController then | |
904 | Comp_Scop := Scope (Original_Record_Component (Comp)); | |
905 | ||
906 | -- If this controller is at the outermost level, no need to | |
907 | -- look for another one | |
908 | ||
909 | if Comp_Scop = T then | |
910 | return Comp; | |
911 | ||
912 | -- Otherwise record the outermost one and continue looking | |
913 | ||
4ac2477e JM |
914 | elsif Res = Empty |
915 | or else Is_Ancestor (Res_Scop, Comp_Scop, Use_Full_View => True) | |
916 | then | |
70482933 RK |
917 | Res := Comp; |
918 | Res_Scop := Comp_Scop; | |
919 | end if; | |
920 | end if; | |
921 | ||
922 | Next_Entity (Comp); | |
923 | end loop; | |
924 | ||
925 | -- If we fall through the loop, there is no controller component | |
926 | ||
927 | return Res; | |
928 | end Controller_Component; | |
929 | ||
930 | ------------------ | |
931 | -- Convert_View -- | |
932 | ------------------ | |
933 | ||
934 | function Convert_View | |
935 | (Proc : Entity_Id; | |
936 | Arg : Node_Id; | |
15ce9ca2 | 937 | Ind : Pos := 1) return Node_Id |
70482933 RK |
938 | is |
939 | Fent : Entity_Id := First_Entity (Proc); | |
940 | Ftyp : Entity_Id; | |
941 | Atyp : Entity_Id; | |
942 | ||
943 | begin | |
944 | for J in 2 .. Ind loop | |
945 | Next_Entity (Fent); | |
946 | end loop; | |
947 | ||
948 | Ftyp := Etype (Fent); | |
949 | ||
d07e197c | 950 | if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then |
70482933 RK |
951 | Atyp := Entity (Subtype_Mark (Arg)); |
952 | else | |
953 | Atyp := Etype (Arg); | |
954 | end if; | |
955 | ||
afe4375b | 956 | if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then |
70482933 RK |
957 | return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg); |
958 | ||
959 | elsif Ftyp /= Atyp | |
960 | and then Present (Atyp) | |
961 | and then | |
962 | (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) | |
a877ccc4 ES |
963 | and then |
964 | Base_Type (Underlying_Type (Atyp)) = | |
965 | Base_Type (Underlying_Type (Ftyp)) | |
70482933 RK |
966 | then |
967 | return Unchecked_Convert_To (Ftyp, Arg); | |
968 | ||
969 | -- If the argument is already a conversion, as generated by | |
970 | -- Make_Init_Call, set the target type to the type of the formal | |
971 | -- directly, to avoid spurious typing problems. | |
972 | ||
d07e197c | 973 | elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion) |
70482933 RK |
974 | and then not Is_Class_Wide_Type (Atyp) |
975 | then | |
976 | Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg))); | |
977 | Set_Etype (Arg, Ftyp); | |
978 | return Arg; | |
979 | ||
980 | else | |
981 | return Arg; | |
982 | end if; | |
983 | end Convert_View; | |
984 | ||
985 | ------------------------------- | |
986 | -- Establish_Transient_Scope -- | |
987 | ------------------------------- | |
988 | ||
989 | -- This procedure is called each time a transient block has to be inserted | |
8fc789c8 | 990 | -- that is to say for each call to a function with unconstrained or tagged |
70482933 RK |
991 | -- result. It creates a new scope on the stack scope in order to enclose |
992 | -- all transient variables generated | |
993 | ||
994 | procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is | |
995 | Loc : constant Source_Ptr := Sloc (N); | |
996 | Wrap_Node : Node_Id; | |
997 | ||
70482933 | 998 | begin |
dbe13a37 ES |
999 | -- Nothing to do for virtual machines where memory is GCed |
1000 | ||
1001 | if VM_Target /= No_VM then | |
1002 | return; | |
1003 | end if; | |
1004 | ||
70482933 RK |
1005 | -- Do not create a transient scope if we are already inside one |
1006 | ||
1007 | for S in reverse Scope_Stack.First .. Scope_Stack.Last loop | |
70482933 | 1008 | if Scope_Stack.Table (S).Is_Transient then |
afe4375b | 1009 | if Sec_Stack then |
70482933 RK |
1010 | Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity); |
1011 | end if; | |
1012 | ||
1013 | return; | |
1014 | ||
1015 | -- If we have encountered Standard there are no enclosing | |
1016 | -- transient scopes. | |
1017 | ||
1018 | elsif Scope_Stack.Table (S).Entity = Standard_Standard then | |
1019 | exit; | |
1020 | ||
1021 | end if; | |
1022 | end loop; | |
1023 | ||
1024 | Wrap_Node := Find_Node_To_Be_Wrapped (N); | |
1025 | ||
1026 | -- Case of no wrap node, false alert, no transient scope needed | |
1027 | ||
1028 | if No (Wrap_Node) then | |
1029 | null; | |
1030 | ||
ffe9aba8 AC |
1031 | -- If the node to wrap is an iteration_scheme, the expression is |
1032 | -- one of the bounds, and the expansion will make an explicit | |
1033 | -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb), | |
1034 | -- so do not apply any transformations here. | |
a9f4e3d2 | 1035 | |
ffe9aba8 AC |
1036 | elsif Nkind (Wrap_Node) = N_Iteration_Scheme then |
1037 | null; | |
70482933 RK |
1038 | |
1039 | else | |
dbe13a37 | 1040 | Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); |
70482933 RK |
1041 | Set_Scope_Is_Transient; |
1042 | ||
afe4375b | 1043 | if Sec_Stack then |
70482933 | 1044 | Set_Uses_Sec_Stack (Current_Scope); |
17c5c8a5 | 1045 | Check_Restriction (No_Secondary_Stack, N); |
70482933 RK |
1046 | end if; |
1047 | ||
1048 | Set_Etype (Current_Scope, Standard_Void_Type); | |
1049 | Set_Node_To_Be_Wrapped (Wrap_Node); | |
1050 | ||
1051 | if Debug_Flag_W then | |
1052 | Write_Str (" <Transient>"); | |
1053 | Write_Eol; | |
1054 | end if; | |
1055 | end if; | |
1056 | end Establish_Transient_Scope; | |
1057 | ||
1058 | ---------------------------- | |
1059 | -- Expand_Cleanup_Actions -- | |
1060 | ---------------------------- | |
1061 | ||
1062 | procedure Expand_Cleanup_Actions (N : Node_Id) is | |
dbe13a37 ES |
1063 | S : constant Entity_Id := Current_Scope; |
1064 | Flist : constant Entity_Id := Finalization_Chain_Entity (S); | |
1065 | Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body; | |
1066 | ||
1067 | Is_Master : constant Boolean := | |
70482933 RK |
1068 | Nkind (N) /= N_Entry_Body |
1069 | and then Is_Task_Master (N); | |
dbe13a37 | 1070 | Is_Protected : constant Boolean := |
70482933 RK |
1071 | Nkind (N) = N_Subprogram_Body |
1072 | and then Is_Protected_Subprogram_Body (N); | |
dbe13a37 | 1073 | Is_Task_Allocation : constant Boolean := |
70482933 RK |
1074 | Nkind (N) = N_Block_Statement |
1075 | and then Is_Task_Allocation_Block (N); | |
dbe13a37 | 1076 | Is_Asynchronous_Call : constant Boolean := |
70482933 RK |
1077 | Nkind (N) = N_Block_Statement |
1078 | and then Is_Asynchronous_Call_Block (N); | |
1079 | ||
dcfa065d GD |
1080 | Previous_At_End_Proc : constant Node_Id := |
1081 | At_End_Proc (Handled_Statement_Sequence (N)); | |
1082 | ||
70482933 | 1083 | Clean : Entity_Id; |
dbe13a37 | 1084 | Loc : Source_Ptr; |
70482933 | 1085 | Mark : Entity_Id := Empty; |
fbf5a39b | 1086 | New_Decls : constant List_Id := New_List; |
70482933 | 1087 | Blok : Node_Id; |
14532762 | 1088 | End_Lab : Node_Id; |
70482933 RK |
1089 | Wrapped : Boolean; |
1090 | Chain : Entity_Id := Empty; | |
1091 | Decl : Node_Id; | |
1092 | Old_Poll : Boolean; | |
1093 | ||
1094 | begin | |
dbe13a37 ES |
1095 | -- If we are generating expanded code for debugging purposes, use |
1096 | -- the Sloc of the point of insertion for the cleanup code. The Sloc | |
1097 | -- will be updated subsequently to reference the proper line in the | |
1098 | -- .dg file. If we are not debugging generated code, use instead | |
1099 | -- No_Location, so that no debug information is generated for the | |
1100 | -- cleanup code. This makes the behavior of the NEXT command in GDB | |
1101 | -- monotonic, and makes the placement of breakpoints more accurate. | |
1102 | ||
1103 | if Debug_Generated_Code then | |
1104 | Loc := Sloc (S); | |
1105 | else | |
1106 | Loc := No_Location; | |
1107 | end if; | |
70482933 RK |
1108 | |
1109 | -- There are cleanup actions only if the secondary stack needs | |
1110 | -- releasing or some finalizations are needed or in the context | |
1111 | -- of tasking | |
1112 | ||
c768e988 | 1113 | if Uses_Sec_Stack (Current_Scope) |
70482933 RK |
1114 | and then not Sec_Stack_Needed_For_Return (Current_Scope) |
1115 | then | |
1116 | null; | |
1117 | elsif No (Flist) | |
1118 | and then not Is_Master | |
1119 | and then not Is_Task | |
1120 | and then not Is_Protected | |
1121 | and then not Is_Task_Allocation | |
1122 | and then not Is_Asynchronous_Call | |
fbf5a39b AC |
1123 | then |
1124 | Clean_Simple_Protected_Objects (N); | |
1125 | return; | |
1126 | end if; | |
1127 | ||
1128 | -- If the current scope is the subprogram body that is the rewriting | |
1129 | -- of a task body, and the descriptors have not been delayed (due to | |
1130 | -- some nested instantiations) do not generate redundant cleanup | |
1131 | -- actions: the cleanup procedure already exists for this body. | |
1132 | ||
1133 | if Nkind (N) = N_Subprogram_Body | |
1134 | and then Nkind (Original_Node (N)) = N_Task_Body | |
1135 | and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N)) | |
70482933 RK |
1136 | then |
1137 | return; | |
1138 | end if; | |
1139 | ||
1140 | -- Set polling off, since we don't need to poll during cleanup | |
1141 | -- actions, and indeed for the cleanup routine, which is executed | |
1142 | -- with aborts deferred, we don't want polling. | |
1143 | ||
1144 | Old_Poll := Polling_Required; | |
1145 | Polling_Required := False; | |
1146 | ||
1147 | -- Make sure we have a declaration list, since we will add to it | |
1148 | ||
1149 | if No (Declarations (N)) then | |
1150 | Set_Declarations (N, New_List); | |
1151 | end if; | |
1152 | ||
1153 | -- The task activation call has already been built for task | |
1154 | -- allocation blocks. | |
1155 | ||
1156 | if not Is_Task_Allocation then | |
1157 | Build_Task_Activation_Call (N); | |
1158 | end if; | |
1159 | ||
1160 | if Is_Master then | |
1161 | Establish_Task_Master (N); | |
1162 | end if; | |
1163 | ||
1164 | -- If secondary stack is in use, expand: | |
1165 | -- _Mxx : constant Mark_Id := SS_Mark; | |
1166 | ||
dbe13a37 ES |
1167 | -- Suppress calls to SS_Mark and SS_Release if VM_Target, |
1168 | -- since we never use the secondary stack on the VM. | |
70482933 RK |
1169 | |
1170 | if Uses_Sec_Stack (Current_Scope) | |
1171 | and then not Sec_Stack_Needed_For_Return (Current_Scope) | |
dbe13a37 | 1172 | and then VM_Target = No_VM |
70482933 | 1173 | then |
c12beea0 | 1174 | Mark := Make_Temporary (Loc, 'M'); |
70482933 RK |
1175 | Append_To (New_Decls, |
1176 | Make_Object_Declaration (Loc, | |
1177 | Defining_Identifier => Mark, | |
1178 | Object_Definition => New_Reference_To (RTE (RE_Mark_Id), Loc), | |
1179 | Expression => | |
1180 | Make_Function_Call (Loc, | |
1181 | Name => New_Reference_To (RTE (RE_SS_Mark), Loc)))); | |
1182 | ||
1183 | Set_Uses_Sec_Stack (Current_Scope, False); | |
1184 | end if; | |
1185 | ||
1186 | -- If finalization list is present then expand: | |
1187 | -- Local_Final_List : System.FI.Finalizable_Ptr; | |
1188 | ||
1189 | if Present (Flist) then | |
1190 | Append_To (New_Decls, | |
1191 | Make_Object_Declaration (Loc, | |
1192 | Defining_Identifier => Flist, | |
1193 | Object_Definition => | |
1194 | New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); | |
1195 | end if; | |
1196 | ||
1197 | -- Clean-up procedure definition | |
1198 | ||
1199 | Clean := Make_Defining_Identifier (Loc, Name_uClean); | |
1200 | Set_Suppress_Elaboration_Warnings (Clean); | |
1201 | Append_To (New_Decls, | |
1202 | Make_Clean (N, Clean, Mark, Flist, | |
1203 | Is_Task, | |
1204 | Is_Master, | |
1205 | Is_Protected, | |
1206 | Is_Task_Allocation, | |
dcfa065d GD |
1207 | Is_Asynchronous_Call, |
1208 | Previous_At_End_Proc)); | |
1209 | ||
1210 | -- The previous AT END procedure, if any, has been captured in Clean: | |
1211 | -- reset it to Empty now because we check further on that we never | |
1212 | -- overwrite an existing AT END call. | |
1213 | ||
1214 | Set_At_End_Proc (Handled_Statement_Sequence (N), Empty); | |
70482933 | 1215 | |
dcfa065d GD |
1216 | -- If exception handlers are present, wrap the Sequence of statements in |
1217 | -- a block because it is not possible to get exception handlers and an | |
1218 | -- AT END call in the same scope. | |
70482933 RK |
1219 | |
1220 | if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then | |
14532762 AC |
1221 | |
1222 | -- Preserve end label to provide proper cross-reference information | |
1223 | ||
1224 | End_Lab := End_Label (Handled_Statement_Sequence (N)); | |
70482933 RK |
1225 | Blok := |
1226 | Make_Block_Statement (Loc, | |
1227 | Handled_Statement_Sequence => Handled_Statement_Sequence (N)); | |
1228 | Set_Handled_Statement_Sequence (N, | |
1229 | Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok))); | |
14532762 | 1230 | Set_End_Label (Handled_Statement_Sequence (N), End_Lab); |
70482933 RK |
1231 | Wrapped := True; |
1232 | ||
dfd99a80 TQ |
1233 | -- Comment needed here, see RH for 1.306 ??? |
1234 | ||
1235 | if Nkind (N) = N_Subprogram_Body then | |
1236 | Set_Has_Nested_Block_With_Handler (Current_Scope); | |
1237 | end if; | |
1238 | ||
70482933 RK |
1239 | -- Otherwise we do not wrap |
1240 | ||
1241 | else | |
1242 | Wrapped := False; | |
1243 | Blok := Empty; | |
1244 | end if; | |
1245 | ||
1246 | -- Don't move the _chain Activation_Chain declaration in task | |
1247 | -- allocation blocks. Task allocation blocks use this object | |
1248 | -- in their cleanup handlers, and gigi complains if it is declared | |
1249 | -- in the sequence of statements of the scope that declares the | |
1250 | -- handler. | |
1251 | ||
1252 | if Is_Task_Allocation then | |
1253 | Chain := Activation_Chain_Entity (N); | |
70482933 | 1254 | |
c1fd002c | 1255 | Decl := First (Declarations (N)); |
70482933 RK |
1256 | while Nkind (Decl) /= N_Object_Declaration |
1257 | or else Defining_Identifier (Decl) /= Chain | |
1258 | loop | |
1259 | Next (Decl); | |
1260 | pragma Assert (Present (Decl)); | |
1261 | end loop; | |
1262 | ||
1263 | Remove (Decl); | |
1264 | Prepend_To (New_Decls, Decl); | |
1265 | end if; | |
1266 | ||
1267 | -- Now we move the declarations into the Sequence of statements | |
1268 | -- in order to get them protected by the AT END call. It may seem | |
1269 | -- weird to put declarations in the sequence of statement but in | |
1270 | -- fact nothing forbids that at the tree level. We also set the | |
1271 | -- First_Real_Statement field so that we remember where the real | |
1272 | -- statements (i.e. original statements) begin. Note that if we | |
1273 | -- wrapped the statements, the first real statement is inside the | |
1274 | -- inner block. If the First_Real_Statement is already set (as is | |
1275 | -- the case for subprogram bodies that are expansions of task bodies) | |
1276 | -- then do not reset it, because its declarative part would migrate | |
1277 | -- to the statement part. | |
1278 | ||
1279 | if not Wrapped then | |
1280 | if No (First_Real_Statement (Handled_Statement_Sequence (N))) then | |
1281 | Set_First_Real_Statement (Handled_Statement_Sequence (N), | |
1282 | First (Statements (Handled_Statement_Sequence (N)))); | |
1283 | end if; | |
1284 | ||
1285 | else | |
1286 | Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok); | |
1287 | end if; | |
1288 | ||
1289 | Append_List_To (Declarations (N), | |
1290 | Statements (Handled_Statement_Sequence (N))); | |
1291 | Set_Statements (Handled_Statement_Sequence (N), Declarations (N)); | |
1292 | ||
1293 | -- We need to reset the Sloc of the handled statement sequence to | |
1294 | -- properly reflect the new initial "statement" in the sequence. | |
1295 | ||
1296 | Set_Sloc | |
1297 | (Handled_Statement_Sequence (N), Sloc (First (Declarations (N)))); | |
1298 | ||
1299 | -- The declarations of the _Clean procedure and finalization chain | |
dcfa065d | 1300 | -- replace the old declarations that have been moved inward. |
70482933 RK |
1301 | |
1302 | Set_Declarations (N, New_Decls); | |
1303 | Analyze_Declarations (New_Decls); | |
1304 | ||
14532762 | 1305 | -- The At_End call is attached to the sequence of statements |
70482933 RK |
1306 | |
1307 | declare | |
1308 | HSS : Node_Id; | |
1309 | ||
1310 | begin | |
1311 | -- If the construct is a protected subprogram, then the call to | |
dcfa065d GD |
1312 | -- the corresponding unprotected subprogram appears in a block which |
1313 | -- is the last statement in the body, and it is this block that must | |
1314 | -- be covered by the At_End handler. | |
70482933 RK |
1315 | |
1316 | if Is_Protected then | |
1317 | HSS := Handled_Statement_Sequence | |
1318 | (Last (Statements (Handled_Statement_Sequence (N)))); | |
1319 | else | |
1320 | HSS := Handled_Statement_Sequence (N); | |
1321 | end if; | |
1322 | ||
dcfa065d GD |
1323 | -- Never overwrite an existing AT END call |
1324 | ||
1325 | pragma Assert (No (At_End_Proc (HSS))); | |
1326 | ||
70482933 RK |
1327 | Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc)); |
1328 | Expand_At_End_Handler (HSS, Empty); | |
1329 | end; | |
1330 | ||
1331 | -- Restore saved polling mode | |
1332 | ||
1333 | Polling_Required := Old_Poll; | |
1334 | end Expand_Cleanup_Actions; | |
1335 | ||
1336 | ------------------------------- | |
1337 | -- Expand_Ctrl_Function_Call -- | |
1338 | ------------------------------- | |
1339 | ||
1340 | procedure Expand_Ctrl_Function_Call (N : Node_Id) is | |
fbf5a39b AC |
1341 | Loc : constant Source_Ptr := Sloc (N); |
1342 | Rtype : constant Entity_Id := Etype (N); | |
1343 | Utype : constant Entity_Id := Underlying_Type (Rtype); | |
1344 | Ref : Node_Id; | |
1345 | Action : Node_Id; | |
1346 | Action2 : Node_Id := Empty; | |
70482933 RK |
1347 | |
1348 | Attach_Level : Uint := Uint_1; | |
1349 | Len_Ref : Node_Id := Empty; | |
1350 | ||
1351 | function Last_Array_Component | |
15ce9ca2 AC |
1352 | (Ref : Node_Id; |
1353 | Typ : Entity_Id) return Node_Id; | |
70482933 RK |
1354 | -- Creates a reference to the last component of the array object |
1355 | -- designated by Ref whose type is Typ. | |
1356 | ||
fbf5a39b AC |
1357 | -------------------------- |
1358 | -- Last_Array_Component -- | |
1359 | -------------------------- | |
1360 | ||
70482933 | 1361 | function Last_Array_Component |
15ce9ca2 AC |
1362 | (Ref : Node_Id; |
1363 | Typ : Entity_Id) return Node_Id | |
70482933 | 1364 | is |
fbf5a39b | 1365 | Index_List : constant List_Id := New_List; |
70482933 RK |
1366 | |
1367 | begin | |
fbf5a39b | 1368 | for N in 1 .. Number_Dimensions (Typ) loop |
70482933 RK |
1369 | Append_To (Index_List, |
1370 | Make_Attribute_Reference (Loc, | |
fbf5a39b | 1371 | Prefix => Duplicate_Subexpr_No_Checks (Ref), |
70482933 RK |
1372 | Attribute_Name => Name_Last, |
1373 | Expressions => New_List ( | |
1374 | Make_Integer_Literal (Loc, N)))); | |
70482933 RK |
1375 | end loop; |
1376 | ||
1377 | return | |
1378 | Make_Indexed_Component (Loc, | |
1379 | Prefix => Duplicate_Subexpr (Ref), | |
1380 | Expressions => Index_List); | |
1381 | end Last_Array_Component; | |
1382 | ||
1383 | -- Start of processing for Expand_Ctrl_Function_Call | |
1384 | ||
1385 | begin | |
33c423c8 AC |
1386 | -- Optimization, if the returned value (which is on the sec-stack) is |
1387 | -- returned again, no need to copy/readjust/finalize, we can just pass | |
1388 | -- the value thru (see Expand_N_Simple_Return_Statement), and thus no | |
70482933 RK |
1389 | -- attachment is needed |
1390 | ||
33c423c8 | 1391 | if Nkind (Parent (N)) = N_Simple_Return_Statement then |
70482933 RK |
1392 | return; |
1393 | end if; | |
1394 | ||
1395 | -- Resolution is now finished, make sure we don't start analysis again | |
bf327c92 | 1396 | -- because of the duplication. |
70482933 RK |
1397 | |
1398 | Set_Analyzed (N); | |
fbf5a39b | 1399 | Ref := Duplicate_Subexpr_No_Checks (N); |
70482933 | 1400 | |
bf327c92 AC |
1401 | -- Now we can generate the Attach Call. Note that this value is always |
1402 | -- on the (secondary) stack and thus is attached to a singly linked | |
1403 | -- final list: | |
fbf5a39b | 1404 | |
70482933 RK |
1405 | -- Resx := F (X)'reference; |
1406 | -- Attach_To_Final_List (_Lx, Resx.all, 1); | |
fbf5a39b | 1407 | |
bf327c92 | 1408 | -- or when there are controlled components: |
fbf5a39b AC |
1409 | |
1410 | -- Attach_To_Final_List (_Lx, Resx._controller, 1); | |
1411 | ||
bf327c92 | 1412 | -- or when it is both Is_Controlled and Has_Controlled_Components: |
fbf5a39b | 1413 | |
70482933 | 1414 | -- Attach_To_Final_List (_Lx, Resx._controller, 1); |
fbf5a39b AC |
1415 | -- Attach_To_Final_List (_Lx, Resx, 1); |
1416 | ||
bf327c92 | 1417 | -- or if it is an array with Is_Controlled (and Has_Controlled) |
fbf5a39b | 1418 | |
70482933 | 1419 | -- Attach_To_Final_List (_Lx, Resx (Resx'last), 3); |
fbf5a39b | 1420 | |
bf327c92 AC |
1421 | -- An attach level of 3 means that a whole array is to be attached to |
1422 | -- the finalization list (including the controlled components). | |
1423 | ||
1424 | -- or if it is an array with Has_Controlled_Components but not | |
1425 | -- Is_Controlled: | |
fbf5a39b | 1426 | |
70482933 RK |
1427 | -- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3); |
1428 | ||
590760eb ES |
1429 | -- Case where type has controlled components |
1430 | ||
70482933 RK |
1431 | if Has_Controlled_Component (Rtype) then |
1432 | declare | |
1433 | T1 : Entity_Id := Rtype; | |
1434 | T2 : Entity_Id := Utype; | |
1435 | ||
1436 | begin | |
1437 | if Is_Array_Type (T2) then | |
1438 | Len_Ref := | |
1439 | Make_Attribute_Reference (Loc, | |
1f07382d AC |
1440 | Prefix => |
1441 | Duplicate_Subexpr_Move_Checks | |
1442 | (Unchecked_Convert_To (T2, Ref)), | |
1443 | Attribute_Name => Name_Length); | |
70482933 RK |
1444 | end if; |
1445 | ||
1446 | while Is_Array_Type (T2) loop | |
1447 | if T1 /= T2 then | |
1448 | Ref := Unchecked_Convert_To (T2, Ref); | |
1449 | end if; | |
fbf5a39b | 1450 | |
70482933 RK |
1451 | Ref := Last_Array_Component (Ref, T2); |
1452 | Attach_Level := Uint_3; | |
1453 | T1 := Component_Type (T2); | |
1454 | T2 := Underlying_Type (T1); | |
1455 | end loop; | |
1456 | ||
fbf5a39b AC |
1457 | -- If the type has controlled components, go to the controller |
1458 | -- except in the case of arrays of controlled objects since in | |
1459 | -- this case objects and their components are already chained | |
1460 | -- and the head of the chain is the last array element. | |
1461 | ||
1462 | if Is_Array_Type (Rtype) and then Is_Controlled (T2) then | |
1463 | null; | |
1464 | ||
1465 | elsif Has_Controlled_Component (T2) then | |
70482933 RK |
1466 | if T1 /= T2 then |
1467 | Ref := Unchecked_Convert_To (T2, Ref); | |
1468 | end if; | |
fbf5a39b | 1469 | |
70482933 RK |
1470 | Ref := |
1471 | Make_Selected_Component (Loc, | |
1472 | Prefix => Ref, | |
1473 | Selector_Name => Make_Identifier (Loc, Name_uController)); | |
1474 | end if; | |
1475 | end; | |
1476 | ||
bf327c92 AC |
1477 | -- Here we know that 'Ref' has a controller so we may as well attach |
1478 | -- it directly. | |
70482933 RK |
1479 | |
1480 | Action := | |
1481 | Make_Attach_Call ( | |
1482 | Obj_Ref => Ref, | |
1483 | Flist_Ref => Find_Final_List (Current_Scope), | |
1484 | With_Attach => Make_Integer_Literal (Loc, Attach_Level)); | |
1485 | ||
fbf5a39b AC |
1486 | -- If it is also Is_Controlled we need to attach the global object |
1487 | ||
1488 | if Is_Controlled (Rtype) then | |
1489 | Action2 := | |
1490 | Make_Attach_Call ( | |
1491 | Obj_Ref => Duplicate_Subexpr_No_Checks (N), | |
1492 | Flist_Ref => Find_Final_List (Current_Scope), | |
1493 | With_Attach => Make_Integer_Literal (Loc, Attach_Level)); | |
1494 | end if; | |
1495 | ||
bf327c92 AC |
1496 | -- Here, we have a controlled type that does not seem to have controlled |
1497 | -- components but it could be a class wide type whose further | |
1498 | -- derivations have controlled components. So we don't know if the | |
1499 | -- object itself needs to be attached or if it has a record controller. | |
1500 | -- We need to call a runtime function (Deep_Tag_Attach) which knows what | |
1501 | -- to do thanks to the RC_Offset in the dispatch table. | |
70482933 | 1502 | |
590760eb | 1503 | else |
70482933 RK |
1504 | Action := |
1505 | Make_Procedure_Call_Statement (Loc, | |
1506 | Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc), | |
1507 | Parameter_Associations => New_List ( | |
1508 | Find_Final_List (Current_Scope), | |
1509 | ||
1510 | Make_Attribute_Reference (Loc, | |
1511 | Prefix => Ref, | |
1512 | Attribute_Name => Name_Address), | |
1513 | ||
1514 | Make_Integer_Literal (Loc, Attach_Level))); | |
1515 | end if; | |
1516 | ||
1517 | if Present (Len_Ref) then | |
1518 | Action := | |
1519 | Make_Implicit_If_Statement (N, | |
23685ae6 AC |
1520 | Condition => |
1521 | Make_Op_Gt (Loc, | |
1522 | Left_Opnd => Len_Ref, | |
1523 | Right_Opnd => Make_Integer_Literal (Loc, 0)), | |
70482933 RK |
1524 | Then_Statements => New_List (Action)); |
1525 | end if; | |
1526 | ||
1527 | Insert_Action (N, Action); | |
fbf5a39b AC |
1528 | if Present (Action2) then |
1529 | Insert_Action (N, Action2); | |
1530 | end if; | |
70482933 RK |
1531 | end Expand_Ctrl_Function_Call; |
1532 | ||
1533 | --------------------------- | |
1534 | -- Expand_N_Package_Body -- | |
1535 | --------------------------- | |
1536 | ||
afe4375b ES |
1537 | -- Add call to Activate_Tasks if body is an activator (actual processing |
1538 | -- is in chapter 9). | |
70482933 RK |
1539 | |
1540 | -- Generate subprogram descriptor for elaboration routine | |
1541 | ||
afe4375b | 1542 | -- Encode entity names in package body |
70482933 RK |
1543 | |
1544 | procedure Expand_N_Package_Body (N : Node_Id) is | |
fbf5a39b | 1545 | Ent : constant Entity_Id := Corresponding_Spec (N); |
70482933 RK |
1546 | |
1547 | begin | |
1548 | -- This is done only for non-generic packages | |
1549 | ||
1550 | if Ekind (Ent) = E_Package then | |
dbe13a37 | 1551 | Push_Scope (Corresponding_Spec (N)); |
33c423c8 AC |
1552 | |
1553 | -- Build dispatch tables of library level tagged types | |
1554 | ||
d07e197c | 1555 | if Is_Library_Level_Entity (Ent) then |
9732e886 JM |
1556 | if Tagged_Type_Expansion then |
1557 | Build_Static_Dispatch_Tables (N); | |
1558 | ||
1559 | -- In VM targets there is no need to build dispatch tables but | |
1560 | -- we must generate the corresponding Type Specific Data record | |
1561 | ||
1562 | elsif Unit (Cunit (Main_Unit)) = N then | |
1563 | Build_VM_TSDs (N); | |
1564 | end if; | |
33c423c8 AC |
1565 | end if; |
1566 | ||
70482933 RK |
1567 | Build_Task_Activation_Call (N); |
1568 | Pop_Scope; | |
1569 | end if; | |
1570 | ||
1571 | Set_Elaboration_Flag (N, Corresponding_Spec (N)); | |
70482933 RK |
1572 | Set_In_Package_Body (Ent, False); |
1573 | ||
1574 | -- Set to encode entity names in package body before gigi is called | |
1575 | ||
1576 | Qualify_Entity_Names (N); | |
1577 | end Expand_N_Package_Body; | |
1578 | ||
1579 | ---------------------------------- | |
1580 | -- Expand_N_Package_Declaration -- | |
1581 | ---------------------------------- | |
1582 | ||
33c423c8 AC |
1583 | -- Add call to Activate_Tasks if there are tasks declared and the package |
1584 | -- has no body. Note that in Ada83, this may result in premature activation | |
1585 | -- of some tasks, given that we cannot tell whether a body will eventually | |
1586 | -- appear. | |
70482933 RK |
1587 | |
1588 | procedure Expand_N_Package_Declaration (N : Node_Id) is | |
33c423c8 AC |
1589 | Spec : constant Node_Id := Specification (N); |
1590 | Id : constant Entity_Id := Defining_Entity (N); | |
afe4375b | 1591 | Decls : List_Id; |
33c423c8 | 1592 | No_Body : Boolean := False; |
afe4375b ES |
1593 | -- True in the case of a package declaration that is a compilation unit |
1594 | -- and for which no associated body will be compiled in | |
1595 | -- this compilation. | |
afe4375b | 1596 | |
33c423c8 | 1597 | begin |
afe4375b ES |
1598 | -- Case of a package declaration other than a compilation unit |
1599 | ||
1600 | if Nkind (Parent (N)) /= N_Compilation_Unit then | |
1601 | null; | |
1602 | ||
1603 | -- Case of a compilation unit that does not require a body | |
1604 | ||
1605 | elsif not Body_Required (Parent (N)) | |
33c423c8 | 1606 | and then not Unit_Requires_Body (Id) |
70482933 | 1607 | then |
afe4375b ES |
1608 | No_Body := True; |
1609 | ||
1610 | -- Special case of generating calling stubs for a remote call interface | |
1611 | -- package: even though the package declaration requires one, the | |
1612 | -- body won't be processed in this compilation (so any stubs for RACWs | |
1613 | -- declared in the package must be generated here, along with the | |
1614 | -- spec). | |
1615 | ||
1616 | elsif Parent (N) = Cunit (Main_Unit) | |
33c423c8 | 1617 | and then Is_Remote_Call_Interface (Id) |
afe4375b ES |
1618 | and then Distribution_Stub_Mode = Generate_Caller_Stub_Body |
1619 | then | |
1620 | No_Body := True; | |
1621 | end if; | |
1622 | ||
1623 | -- For a package declaration that implies no associated body, generate | |
1624 | -- task activation call and RACW supporting bodies now (since we won't | |
1625 | -- have a specific separate compilation unit for that). | |
1626 | ||
1627 | if No_Body then | |
33c423c8 | 1628 | Push_Scope (Id); |
afe4375b | 1629 | |
33c423c8 | 1630 | if Has_RACW (Id) then |
afe4375b ES |
1631 | |
1632 | -- Generate RACW subprogram bodies | |
1633 | ||
1634 | Decls := Private_Declarations (Spec); | |
1635 | ||
1636 | if No (Decls) then | |
1637 | Decls := Visible_Declarations (Spec); | |
1638 | end if; | |
1639 | ||
1640 | if No (Decls) then | |
1641 | Decls := New_List; | |
1642 | Set_Visible_Declarations (Spec, Decls); | |
1643 | end if; | |
1644 | ||
33c423c8 | 1645 | Append_RACW_Bodies (Decls, Id); |
afe4375b ES |
1646 | Analyze_List (Decls); |
1647 | end if; | |
1648 | ||
1649 | if Present (Activation_Chain_Entity (N)) then | |
1650 | ||
1651 | -- Generate task activation call as last step of elaboration | |
1652 | ||
1653 | Build_Task_Activation_Call (N); | |
1654 | end if; | |
1655 | ||
70482933 RK |
1656 | Pop_Scope; |
1657 | end if; | |
1658 | ||
33c423c8 AC |
1659 | -- Build dispatch tables of library level tagged types |
1660 | ||
1661 | if Is_Compilation_Unit (Id) | |
1662 | or else (Is_Generic_Instance (Id) | |
1663 | and then Is_Library_Level_Entity (Id)) | |
1664 | then | |
9732e886 JM |
1665 | if Tagged_Type_Expansion then |
1666 | Build_Static_Dispatch_Tables (N); | |
1667 | ||
1668 | -- In VM targets there is no need to build dispatch tables but | |
1669 | -- we must generate the corresponding Type Specific Data record | |
1670 | ||
1671 | elsif Unit (Cunit (Main_Unit)) = N then | |
1672 | ||
1673 | -- Enter the scope of the package because the new declarations | |
1674 | -- are appended at the end of the package and must be analyzed | |
1675 | -- in that context. | |
1676 | ||
1677 | Push_Scope (Id); | |
1678 | ||
1679 | if Is_Generic_Instance (Main_Unit_Entity) then | |
1680 | if Package_Instantiation (Main_Unit_Entity) = N then | |
1681 | Build_VM_TSDs (N); | |
1682 | end if; | |
1683 | ||
1684 | else | |
1685 | Build_VM_TSDs (N); | |
1686 | end if; | |
1687 | ||
1688 | Pop_Scope; | |
1689 | end if; | |
33c423c8 AC |
1690 | end if; |
1691 | ||
70482933 RK |
1692 | -- Note: it is not necessary to worry about generating a subprogram |
1693 | -- descriptor, since the only way to get exception handlers into a | |
1694 | -- package spec is to include instantiations, and that would cause | |
1695 | -- generation of subprogram descriptors to be delayed in any case. | |
1696 | ||
1697 | -- Set to encode entity names in package spec before gigi is called | |
1698 | ||
1699 | Qualify_Entity_Names (N); | |
1700 | end Expand_N_Package_Declaration; | |
1701 | ||
1702 | --------------------- | |
1703 | -- Find_Final_List -- | |
1704 | --------------------- | |
1705 | ||
1706 | function Find_Final_List | |
15ce9ca2 AC |
1707 | (E : Entity_Id; |
1708 | Ref : Node_Id := Empty) return Node_Id | |
70482933 RK |
1709 | is |
1710 | Loc : constant Source_Ptr := Sloc (Ref); | |
1711 | S : Entity_Id; | |
1712 | Id : Entity_Id; | |
1713 | R : Node_Id; | |
1714 | ||
1715 | begin | |
dcfa065d GD |
1716 | -- If the restriction No_Finalization applies, then there's not any |
1717 | -- finalization list available to return, so return Empty. | |
1718 | ||
1719 | if Restriction_Active (No_Finalization) then | |
1720 | return Empty; | |
1721 | ||
70482933 | 1722 | -- Case of an internal component. The Final list is the record |
33c423c8 | 1723 | -- controller of the enclosing record. |
70482933 | 1724 | |
dcfa065d | 1725 | elsif Present (Ref) then |
70482933 RK |
1726 | R := Ref; |
1727 | loop | |
1728 | case Nkind (R) is | |
1729 | when N_Unchecked_Type_Conversion | N_Type_Conversion => | |
1730 | R := Expression (R); | |
1731 | ||
1732 | when N_Indexed_Component | N_Explicit_Dereference => | |
1733 | R := Prefix (R); | |
1734 | ||
1735 | when N_Selected_Component => | |
1736 | R := Prefix (R); | |
1737 | exit; | |
1738 | ||
1739 | when N_Identifier => | |
1740 | exit; | |
1741 | ||
1742 | when others => | |
1743 | raise Program_Error; | |
1744 | end case; | |
1745 | end loop; | |
1746 | ||
1747 | return | |
1748 | Make_Selected_Component (Loc, | |
7675ad4f | 1749 | Prefix => |
70482933 RK |
1750 | Make_Selected_Component (Loc, |
1751 | Prefix => R, | |
1752 | Selector_Name => Make_Identifier (Loc, Name_uController)), | |
1753 | Selector_Name => Make_Identifier (Loc, Name_F)); | |
1754 | ||
dcfa065d GD |
1755 | -- Case of a dynamically allocated object whose access type has an |
1756 | -- Associated_Final_Chain. The final list is the corresponding list | |
1757 | -- controller (the next entity in the scope of the access type with | |
1758 | -- the right type). If the type comes from a With_Type clause, no | |
1759 | -- controller was created, we use the global chain instead. (The code | |
1760 | -- related to with_type clauses should presumably be removed at some | |
1761 | -- point since that feature is obsolete???) | |
70482933 | 1762 | |
afe4375b ES |
1763 | -- An anonymous access type either has a list created for it when the |
1764 | -- allocator is a for an access parameter or an access discriminant, | |
1765 | -- or else it uses the list of the enclosing dynamic scope, when the | |
1766 | -- context is a declaration or an assignment. | |
1767 | ||
1768 | elsif Is_Access_Type (E) | |
dcfa065d GD |
1769 | and then (Present (Associated_Final_Chain (E)) |
1770 | or else From_With_Type (E)) | |
afe4375b | 1771 | then |
dcfa065d GD |
1772 | if From_With_Type (E) then |
1773 | return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); | |
1774 | ||
1775 | -- Use the access type's associated finalization chain | |
1776 | ||
1777 | else | |
44d8d2bb ES |
1778 | return |
1779 | Make_Selected_Component (Loc, | |
1780 | Prefix => | |
1781 | New_Reference_To | |
1782 | (Associated_Final_Chain (Base_Type (E)), Loc), | |
1783 | Selector_Name => Make_Identifier (Loc, Name_F)); | |
44d8d2bb | 1784 | end if; |
70482933 RK |
1785 | |
1786 | else | |
a780db15 | 1787 | S := Nearest_Dynamic_Scope (E); |
70482933 | 1788 | |
c5288c90 AC |
1789 | -- When the finalization chain entity is 'Error', it means that there |
1790 | -- should not be any chain at that level and that the enclosing one | |
1791 | -- should be used. | |
70482933 RK |
1792 | |
1793 | -- This is a nasty kludge, see ??? note in exp_ch11 | |
1794 | ||
1795 | while Finalization_Chain_Entity (S) = Error loop | |
1796 | S := Enclosing_Dynamic_Scope (S); | |
1797 | end loop; | |
1798 | ||
1799 | if S = Standard_Standard then | |
1800 | return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E)); | |
1801 | else | |
1802 | if No (Finalization_Chain_Entity (S)) then | |
c5288c90 AC |
1803 | |
1804 | -- In the case where the scope is a subprogram, retrieve the | |
1805 | -- Sloc of subprogram's body for association with the chain, | |
1806 | -- since using the Sloc of the spec would be confusing during | |
1807 | -- source-line stepping within the debugger. | |
1808 | ||
1809 | declare | |
1810 | Flist_Loc : Source_Ptr := Sloc (S); | |
1811 | Subp_Body : Node_Id; | |
1812 | ||
1813 | begin | |
1814 | if Ekind (S) in Subprogram_Kind then | |
1815 | Subp_Body := Unit_Declaration_Node (S); | |
1816 | ||
1817 | if Nkind (Subp_Body) /= N_Subprogram_Body then | |
1818 | Subp_Body := Corresponding_Body (Subp_Body); | |
1819 | end if; | |
1820 | ||
1821 | if Present (Subp_Body) then | |
1822 | Flist_Loc := Sloc (Subp_Body); | |
1823 | end if; | |
1824 | end if; | |
1825 | ||
c12beea0 | 1826 | Id := Make_Temporary (Flist_Loc, 'F'); |
c5288c90 AC |
1827 | end; |
1828 | ||
70482933 RK |
1829 | Set_Finalization_Chain_Entity (S, Id); |
1830 | ||
1831 | -- Set momentarily some semantics attributes to allow normal | |
1832 | -- analysis of expansions containing references to this chain. | |
1833 | -- Will be fully decorated during the expansion of the scope | |
33c423c8 | 1834 | -- itself. |
70482933 RK |
1835 | |
1836 | Set_Ekind (Id, E_Variable); | |
1837 | Set_Etype (Id, RTE (RE_Finalizable_Ptr)); | |
1838 | end if; | |
1839 | ||
1840 | return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E)); | |
1841 | end if; | |
1842 | end if; | |
1843 | end Find_Final_List; | |
1844 | ||
1845 | ----------------------------- | |
1846 | -- Find_Node_To_Be_Wrapped -- | |
1847 | ----------------------------- | |
1848 | ||
1849 | function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is | |
1850 | P : Node_Id; | |
1851 | The_Parent : Node_Id; | |
1852 | ||
1853 | begin | |
1854 | The_Parent := N; | |
1855 | loop | |
1856 | P := The_Parent; | |
1857 | pragma Assert (P /= Empty); | |
1858 | The_Parent := Parent (P); | |
1859 | ||
1860 | case Nkind (The_Parent) is | |
1861 | ||
1862 | -- Simple statement can be wrapped | |
1863 | ||
33c423c8 | 1864 | when N_Pragma => |
70482933 RK |
1865 | return The_Parent; |
1866 | ||
1867 | -- Usually assignments are good candidate for wrapping | |
1868 | -- except when they have been generated as part of a | |
1869 | -- controlled aggregate where the wrapping should take | |
1870 | -- place more globally. | |
1871 | ||
1872 | when N_Assignment_Statement => | |
1873 | if No_Ctrl_Actions (The_Parent) then | |
1874 | null; | |
1875 | else | |
1876 | return The_Parent; | |
1877 | end if; | |
1878 | ||
1879 | -- An entry call statement is a special case if it occurs in | |
1880 | -- the context of a Timed_Entry_Call. In this case we wrap | |
1881 | -- the entire timed entry call. | |
1882 | ||
1883 | when N_Entry_Call_Statement | | |
1884 | N_Procedure_Call_Statement => | |
1885 | if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative | |
d07e197c JM |
1886 | and then Nkind_In (Parent (Parent (The_Parent)), |
1887 | N_Timed_Entry_Call, | |
1888 | N_Conditional_Entry_Call) | |
70482933 RK |
1889 | then |
1890 | return Parent (Parent (The_Parent)); | |
1891 | else | |
1892 | return The_Parent; | |
1893 | end if; | |
1894 | ||
1895 | -- Object declarations are also a boundary for the transient scope | |
1896 | -- even if they are not really wrapped | |
1897 | -- (see Wrap_Transient_Declaration) | |
1898 | ||
1899 | when N_Object_Declaration | | |
1900 | N_Object_Renaming_Declaration | | |
1901 | N_Subtype_Declaration => | |
1902 | return The_Parent; | |
1903 | ||
1904 | -- The expression itself is to be wrapped if its parent is a | |
1905 | -- compound statement or any other statement where the expression | |
1906 | -- is known to be scalar | |
1907 | ||
1908 | when N_Accept_Alternative | | |
1909 | N_Attribute_Definition_Clause | | |
1910 | N_Case_Statement | | |
1911 | N_Code_Statement | | |
1912 | N_Delay_Alternative | | |
1913 | N_Delay_Until_Statement | | |
1914 | N_Delay_Relative_Statement | | |
1915 | N_Discriminant_Association | | |
1916 | N_Elsif_Part | | |
1917 | N_Entry_Body_Formal_Part | | |
1918 | N_Exit_Statement | | |
1919 | N_If_Statement | | |
1920 | N_Iteration_Scheme | | |
1921 | N_Terminate_Alternative => | |
1922 | return P; | |
1923 | ||
33c423c8 | 1924 | when N_Attribute_Reference => |
70482933 RK |
1925 | |
1926 | if Is_Procedure_Attribute_Name | |
1927 | (Attribute_Name (The_Parent)) | |
1928 | then | |
1929 | return The_Parent; | |
1930 | end if; | |
1931 | ||
f4d379b8 HK |
1932 | -- A raise statement can be wrapped. This will arise when the |
1933 | -- expression in a raise_with_expression uses the secondary | |
1934 | -- stack, for example. | |
1935 | ||
33c423c8 | 1936 | when N_Raise_Statement => |
f4d379b8 HK |
1937 | return The_Parent; |
1938 | ||
a9f4e3d2 AC |
1939 | -- If the expression is within the iteration scheme of a loop, |
1940 | -- we must create a declaration for it, followed by an assignment | |
1941 | -- in order to have a usable statement to wrap. | |
70482933 RK |
1942 | |
1943 | when N_Loop_Parameter_Specification => | |
a9f4e3d2 | 1944 | return Parent (The_Parent); |
70482933 RK |
1945 | |
1946 | -- The following nodes contains "dummy calls" which don't | |
1947 | -- need to be wrapped. | |
1948 | ||
1949 | when N_Parameter_Specification | | |
1950 | N_Discriminant_Specification | | |
1951 | N_Component_Declaration => | |
1952 | return Empty; | |
1953 | ||
1954 | -- The return statement is not to be wrapped when the function | |
1955 | -- itself needs wrapping at the outer-level | |
1956 | ||
33c423c8 | 1957 | when N_Simple_Return_Statement => |
05350ac6 BD |
1958 | declare |
1959 | Applies_To : constant Entity_Id := | |
1960 | Return_Applies_To | |
1961 | (Return_Statement_Entity (The_Parent)); | |
1962 | Return_Type : constant Entity_Id := Etype (Applies_To); | |
1963 | begin | |
1964 | if Requires_Transient_Scope (Return_Type) then | |
1965 | return Empty; | |
1966 | else | |
1967 | return The_Parent; | |
1968 | end if; | |
1969 | end; | |
70482933 RK |
1970 | |
1971 | -- If we leave a scope without having been able to find a node to | |
1972 | -- wrap, something is going wrong but this can happen in error | |
1973 | -- situation that are not detected yet (such as a dynamic string | |
1974 | -- in a pragma export) | |
1975 | ||
1976 | when N_Subprogram_Body | | |
1977 | N_Package_Declaration | | |
1978 | N_Package_Body | | |
1979 | N_Block_Statement => | |
1980 | return Empty; | |
1981 | ||
1982 | -- otherwise continue the search | |
1983 | ||
1984 | when others => | |
1985 | null; | |
1986 | end case; | |
1987 | end loop; | |
1988 | end Find_Node_To_Be_Wrapped; | |
1989 | ||
1990 | ---------------------- | |
1991 | -- Global_Flist_Ref -- | |
1992 | ---------------------- | |
1993 | ||
1994 | function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean is | |
1995 | Flist : Entity_Id; | |
1996 | ||
1997 | begin | |
1998 | -- Look for the Global_Final_List | |
1999 | ||
2000 | if Is_Entity_Name (Flist_Ref) then | |
2001 | Flist := Entity (Flist_Ref); | |
2002 | ||
2003 | -- Look for the final list associated with an access to controlled | |
2004 | ||
2005 | elsif Nkind (Flist_Ref) = N_Selected_Component | |
2006 | and then Is_Entity_Name (Prefix (Flist_Ref)) | |
2007 | then | |
2008 | Flist := Entity (Prefix (Flist_Ref)); | |
2009 | else | |
2010 | return False; | |
2011 | end if; | |
2012 | ||
2013 | return Present (Flist) | |
2014 | and then Present (Scope (Flist)) | |
2015 | and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard; | |
2016 | end Global_Flist_Ref; | |
2017 | ||
2018 | ---------------------------------- | |
2019 | -- Has_New_Controlled_Component -- | |
2020 | ---------------------------------- | |
2021 | ||
2022 | function Has_New_Controlled_Component (E : Entity_Id) return Boolean is | |
2023 | Comp : Entity_Id; | |
2024 | ||
2025 | begin | |
2026 | if not Is_Tagged_Type (E) then | |
2027 | return Has_Controlled_Component (E); | |
2028 | elsif not Is_Derived_Type (E) then | |
2029 | return Has_Controlled_Component (E); | |
2030 | end if; | |
2031 | ||
2032 | Comp := First_Component (E); | |
2033 | while Present (Comp) loop | |
2034 | ||
2035 | if Chars (Comp) = Name_uParent then | |
2036 | null; | |
2037 | ||
2038 | elsif Scope (Original_Record_Component (Comp)) = E | |
048e5cef | 2039 | and then Needs_Finalization (Etype (Comp)) |
70482933 RK |
2040 | then |
2041 | return True; | |
2042 | end if; | |
2043 | ||
2044 | Next_Component (Comp); | |
2045 | end loop; | |
2046 | ||
2047 | return False; | |
2048 | end Has_New_Controlled_Component; | |
2049 | ||
2050 | -------------------------- | |
2051 | -- In_Finalization_Root -- | |
2052 | -------------------------- | |
2053 | ||
2054 | -- It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but | |
2055 | -- the purpose of this function is to avoid a circular call to Rtsfind | |
2056 | -- which would been caused by such a test. | |
2057 | ||
2058 | function In_Finalization_Root (E : Entity_Id) return Boolean is | |
2059 | S : constant Entity_Id := Scope (E); | |
2060 | ||
2061 | begin | |
2062 | return Chars (Scope (S)) = Name_System | |
2063 | and then Chars (S) = Name_Finalization_Root | |
2064 | and then Scope (Scope (S)) = Standard_Standard; | |
2065 | end In_Finalization_Root; | |
2066 | ||
2067 | ------------------------------------ | |
2068 | -- Insert_Actions_In_Scope_Around -- | |
2069 | ------------------------------------ | |
2070 | ||
2071 | procedure Insert_Actions_In_Scope_Around (N : Node_Id) is | |
5d09245e AC |
2072 | SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); |
2073 | Target : Node_Id; | |
70482933 RK |
2074 | |
2075 | begin | |
dbe13a37 | 2076 | -- If the node to be wrapped is the triggering statement of an |
5d09245e AC |
2077 | -- asynchronous select, it is not part of a statement list. The |
2078 | -- actions must be inserted before the Select itself, which is | |
dbe13a37 ES |
2079 | -- part of some list of statements. Note that the triggering |
2080 | -- alternative includes the triggering statement and an optional | |
2081 | -- statement list. If the node to be wrapped is part of that list, | |
2082 | -- the normal insertion applies. | |
5d09245e | 2083 | |
dbe13a37 ES |
2084 | if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative |
2085 | and then not Is_List_Member (Node_To_Be_Wrapped) | |
2086 | then | |
5d09245e AC |
2087 | Target := Parent (Parent (Node_To_Be_Wrapped)); |
2088 | else | |
2089 | Target := N; | |
2090 | end if; | |
2091 | ||
70482933 | 2092 | if Present (SE.Actions_To_Be_Wrapped_Before) then |
5d09245e | 2093 | Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before); |
70482933 RK |
2094 | SE.Actions_To_Be_Wrapped_Before := No_List; |
2095 | end if; | |
2096 | ||
2097 | if Present (SE.Actions_To_Be_Wrapped_After) then | |
5d09245e | 2098 | Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After); |
70482933 RK |
2099 | SE.Actions_To_Be_Wrapped_After := No_List; |
2100 | end if; | |
2101 | end Insert_Actions_In_Scope_Around; | |
2102 | ||
2103 | ----------------------- | |
2104 | -- Make_Adjust_Call -- | |
2105 | ----------------------- | |
2106 | ||
2107 | function Make_Adjust_Call | |
dfd99a80 TQ |
2108 | (Ref : Node_Id; |
2109 | Typ : Entity_Id; | |
2110 | Flist_Ref : Node_Id; | |
2111 | With_Attach : Node_Id; | |
2112 | Allocator : Boolean := False) return List_Id | |
70482933 RK |
2113 | is |
2114 | Loc : constant Source_Ptr := Sloc (Ref); | |
2115 | Res : constant List_Id := New_List; | |
2116 | Utyp : Entity_Id; | |
2117 | Proc : Entity_Id; | |
2118 | Cref : Node_Id := Ref; | |
2119 | Cref2 : Node_Id; | |
2120 | Attach : Node_Id := With_Attach; | |
2121 | ||
2122 | begin | |
2123 | if Is_Class_Wide_Type (Typ) then | |
2124 | Utyp := Underlying_Type (Base_Type (Root_Type (Typ))); | |
2125 | else | |
2126 | Utyp := Underlying_Type (Base_Type (Typ)); | |
2127 | end if; | |
2128 | ||
2129 | Set_Assignment_OK (Cref); | |
2130 | ||
2131 | -- Deal with non-tagged derivation of private views | |
2132 | ||
2133 | if Is_Untagged_Derivation (Typ) then | |
2134 | Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); | |
2135 | Cref := Unchecked_Convert_To (Utyp, Cref); | |
2136 | Set_Assignment_OK (Cref); | |
2137 | -- To prevent problems with UC see 1.156 RH ??? | |
2138 | end if; | |
2139 | ||
2140 | -- If the underlying_type is a subtype, we are dealing with | |
2141 | -- the completion of a private type. We need to access | |
2142 | -- the base type and generate a conversion to it. | |
2143 | ||
2144 | if Utyp /= Base_Type (Utyp) then | |
2145 | pragma Assert (Is_Private_Type (Typ)); | |
2146 | Utyp := Base_Type (Utyp); | |
2147 | Cref := Unchecked_Convert_To (Utyp, Cref); | |
2148 | end if; | |
2149 | ||
fbf5a39b AC |
2150 | -- If the object is unanalyzed, set its expected type for use |
2151 | -- in Convert_View in case an additional conversion is needed. | |
2152 | ||
2153 | if No (Etype (Cref)) | |
2154 | and then Nkind (Cref) /= N_Unchecked_Type_Conversion | |
2155 | then | |
2156 | Set_Etype (Cref, Typ); | |
2157 | end if; | |
2158 | ||
70482933 RK |
2159 | -- We do not need to attach to one of the Global Final Lists |
2160 | -- the objects whose type is Finalize_Storage_Only | |
2161 | ||
2162 | if Finalize_Storage_Only (Typ) | |
2163 | and then (Global_Flist_Ref (Flist_Ref) | |
2164 | or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) | |
2165 | = Standard_True) | |
2166 | then | |
2167 | Attach := Make_Integer_Literal (Loc, 0); | |
2168 | end if; | |
2169 | ||
dfd99a80 TQ |
2170 | -- Special case for allocators: need initialization of the chain |
2171 | -- pointers. For the 0 case, reset them to null. | |
2172 | ||
2173 | if Allocator then | |
2174 | pragma Assert (Nkind (Attach) = N_Integer_Literal); | |
2175 | ||
2176 | if Intval (Attach) = 0 then | |
2177 | Set_Intval (Attach, Uint_4); | |
2178 | end if; | |
2179 | end if; | |
2180 | ||
70482933 | 2181 | -- Generate: |
dfd99a80 | 2182 | -- Deep_Adjust (Flist_Ref, Ref, Attach); |
70482933 RK |
2183 | |
2184 | if Has_Controlled_Component (Utyp) | |
2185 | or else Is_Class_Wide_Type (Typ) | |
2186 | then | |
2187 | if Is_Tagged_Type (Utyp) then | |
fbf5a39b | 2188 | Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust); |
70482933 RK |
2189 | |
2190 | else | |
fbf5a39b | 2191 | Proc := TSS (Utyp, TSS_Deep_Adjust); |
70482933 RK |
2192 | end if; |
2193 | ||
2194 | Cref := Convert_View (Proc, Cref, 2); | |
2195 | ||
2196 | Append_To (Res, | |
2197 | Make_Procedure_Call_Statement (Loc, | |
2198 | Name => New_Reference_To (Proc, Loc), | |
2199 | Parameter_Associations => | |
2200 | New_List (Flist_Ref, Cref, Attach))); | |
2201 | ||
2202 | -- Generate: | |
2203 | -- if With_Attach then | |
2204 | -- Attach_To_Final_List (Ref, Flist_Ref); | |
2205 | -- end if; | |
2206 | -- Adjust (Ref); | |
2207 | ||
2208 | else -- Is_Controlled (Utyp) | |
2209 | ||
2210 | Proc := Find_Prim_Op (Utyp, Name_Of (Adjust_Case)); | |
2211 | Cref := Convert_View (Proc, Cref); | |
2212 | Cref2 := New_Copy_Tree (Cref); | |
2213 | ||
2214 | Append_To (Res, | |
2215 | Make_Procedure_Call_Statement (Loc, | |
2216 | Name => New_Reference_To (Proc, Loc), | |
2217 | Parameter_Associations => New_List (Cref2))); | |
2218 | ||
2219 | Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach)); | |
70482933 RK |
2220 | end if; |
2221 | ||
2222 | return Res; | |
2223 | end Make_Adjust_Call; | |
2224 | ||
2225 | ---------------------- | |
2226 | -- Make_Attach_Call -- | |
2227 | ---------------------- | |
2228 | ||
2229 | -- Generate: | |
2230 | -- System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link) | |
2231 | ||
2232 | function Make_Attach_Call | |
15ce9ca2 AC |
2233 | (Obj_Ref : Node_Id; |
2234 | Flist_Ref : Node_Id; | |
2235 | With_Attach : Node_Id) return Node_Id | |
70482933 RK |
2236 | is |
2237 | Loc : constant Source_Ptr := Sloc (Obj_Ref); | |
2238 | ||
2239 | begin | |
2240 | -- Optimization: If the number of links is statically '0', don't | |
2241 | -- call the attach_proc. | |
2242 | ||
2243 | if Nkind (With_Attach) = N_Integer_Literal | |
2244 | and then Intval (With_Attach) = Uint_0 | |
2245 | then | |
2246 | return Make_Null_Statement (Loc); | |
2247 | end if; | |
2248 | ||
2249 | return | |
2250 | Make_Procedure_Call_Statement (Loc, | |
2251 | Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc), | |
2252 | Parameter_Associations => New_List ( | |
2253 | Flist_Ref, | |
2254 | OK_Convert_To (RTE (RE_Finalizable), Obj_Ref), | |
2255 | With_Attach)); | |
2256 | end Make_Attach_Call; | |
2257 | ||
2258 | ---------------- | |
2259 | -- Make_Clean -- | |
2260 | ---------------- | |
2261 | ||
2262 | function Make_Clean | |
2263 | (N : Node_Id; | |
2264 | Clean : Entity_Id; | |
2265 | Mark : Entity_Id; | |
2266 | Flist : Entity_Id; | |
2267 | Is_Task : Boolean; | |
2268 | Is_Master : Boolean; | |
2269 | Is_Protected_Subprogram : Boolean; | |
2270 | Is_Task_Allocation_Block : Boolean; | |
dcfa065d GD |
2271 | Is_Asynchronous_Call_Block : Boolean; |
2272 | Chained_Cleanup_Action : Node_Id) return Node_Id | |
70482933 | 2273 | is |
fbf5a39b AC |
2274 | Loc : constant Source_Ptr := Sloc (Clean); |
2275 | Stmt : constant List_Id := New_List; | |
70482933 | 2276 | |
70482933 RK |
2277 | Sbody : Node_Id; |
2278 | Spec : Node_Id; | |
2279 | Name : Node_Id; | |
2280 | Param : Node_Id; | |
70482933 RK |
2281 | Param_Type : Entity_Id; |
2282 | Pid : Entity_Id := Empty; | |
2283 | Cancel_Param : Entity_Id; | |
2284 | ||
2285 | begin | |
2286 | if Is_Task then | |
2287 | if Restricted_Profile then | |
2288 | Append_To | |
2289 | (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task)); | |
2290 | else | |
2291 | Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task)); | |
2292 | end if; | |
2293 | ||
2294 | elsif Is_Master then | |
6e937c1c | 2295 | if Restriction_Active (No_Task_Hierarchy) = False then |
70482933 RK |
2296 | Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master)); |
2297 | end if; | |
2298 | ||
2299 | elsif Is_Protected_Subprogram then | |
2300 | ||
2301 | -- Add statements to the cleanup handler of the (ordinary) | |
2302 | -- subprogram expanded to implement a protected subprogram, | |
a877ccc4 | 2303 | -- unlocking the protected object parameter and undeferring abort. |
70482933 RK |
2304 | -- If this is a protected procedure, and the object contains |
2305 | -- entries, this also calls the entry service routine. | |
2306 | ||
2307 | -- NOTE: This cleanup handler references _object, a parameter | |
2308 | -- to the procedure. | |
2309 | ||
14532762 | 2310 | -- Find the _object parameter representing the protected object |
70482933 RK |
2311 | |
2312 | Spec := Parent (Corresponding_Spec (N)); | |
2313 | ||
2314 | Param := First (Parameter_Specifications (Spec)); | |
2315 | loop | |
2316 | Param_Type := Etype (Parameter_Type (Param)); | |
2317 | ||
2318 | if Ekind (Param_Type) = E_Record_Type then | |
2319 | Pid := Corresponding_Concurrent_Type (Param_Type); | |
2320 | end if; | |
2321 | ||
dfd99a80 | 2322 | exit when No (Param) or else Present (Pid); |
70482933 RK |
2323 | Next (Param); |
2324 | end loop; | |
2325 | ||
2326 | pragma Assert (Present (Param)); | |
2327 | ||
2328 | -- If the associated protected object declares entries, | |
2329 | -- a protected procedure has to service entry queues. | |
2330 | -- In this case, add | |
2331 | ||
2332 | -- Service_Entries (_object._object'Access); | |
2333 | ||
2334 | -- _object is the record used to implement the protected object. | |
2335 | -- It is a parameter to the protected subprogram. | |
2336 | ||
2337 | if Nkind (Specification (N)) = N_Procedure_Specification | |
2338 | and then Has_Entries (Pid) | |
2339 | then | |
c364d9be JM |
2340 | case Corresponding_Runtime_Package (Pid) is |
2341 | when System_Tasking_Protected_Objects_Entries => | |
2342 | Name := New_Reference_To (RTE (RE_Service_Entries), Loc); | |
2343 | ||
2344 | when System_Tasking_Protected_Objects_Single_Entry => | |
2345 | Name := New_Reference_To (RTE (RE_Service_Entry), Loc); | |
2346 | ||
2347 | when others => | |
2348 | raise Program_Error; | |
2349 | end case; | |
70482933 RK |
2350 | |
2351 | Append_To (Stmt, | |
2352 | Make_Procedure_Call_Statement (Loc, | |
2353 | Name => Name, | |
2354 | Parameter_Associations => New_List ( | |
2355 | Make_Attribute_Reference (Loc, | |
7675ad4f | 2356 | Prefix => |
70482933 | 2357 | Make_Selected_Component (Loc, |
7675ad4f AC |
2358 | Prefix => |
2359 | New_Reference_To (Defining_Identifier (Param), Loc), | |
70482933 RK |
2360 | Selector_Name => |
2361 | Make_Identifier (Loc, Name_uObject)), | |
2362 | Attribute_Name => Name_Unchecked_Access)))); | |
70482933 | 2363 | |
8a7988f5 AC |
2364 | else |
2365 | -- Unlock (_object._object'Access); | |
70482933 | 2366 | |
8a7988f5 AC |
2367 | -- object is the record used to implement the protected object. |
2368 | -- It is a parameter to the protected subprogram. | |
70482933 | 2369 | |
c364d9be JM |
2370 | case Corresponding_Runtime_Package (Pid) is |
2371 | when System_Tasking_Protected_Objects_Entries => | |
8a7988f5 | 2372 | Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); |
c364d9be JM |
2373 | |
2374 | when System_Tasking_Protected_Objects_Single_Entry => | |
8a7988f5 | 2375 | Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); |
8a7988f5 | 2376 | |
c364d9be JM |
2377 | when System_Tasking_Protected_Objects => |
2378 | Name := New_Reference_To (RTE (RE_Unlock), Loc); | |
2379 | ||
2380 | when others => | |
2381 | raise Program_Error; | |
2382 | end case; | |
70482933 | 2383 | |
8a7988f5 AC |
2384 | Append_To (Stmt, |
2385 | Make_Procedure_Call_Statement (Loc, | |
2386 | Name => Name, | |
2387 | Parameter_Associations => New_List ( | |
2388 | Make_Attribute_Reference (Loc, | |
2389 | Prefix => | |
2390 | Make_Selected_Component (Loc, | |
2391 | Prefix => | |
2392 | New_Reference_To (Defining_Identifier (Param), Loc), | |
2393 | Selector_Name => | |
2394 | Make_Identifier (Loc, Name_uObject)), | |
2395 | Attribute_Name => Name_Unchecked_Access)))); | |
70482933 RK |
2396 | end if; |
2397 | ||
70482933 | 2398 | if Abort_Allowed then |
8a7988f5 | 2399 | |
70482933 RK |
2400 | -- Abort_Undefer; |
2401 | ||
2402 | Append_To (Stmt, | |
2403 | Make_Procedure_Call_Statement (Loc, | |
2404 | Name => | |
2405 | New_Reference_To ( | |
2406 | RTE (RE_Abort_Undefer), Loc), | |
2407 | Parameter_Associations => Empty_List)); | |
2408 | end if; | |
2409 | ||
2410 | elsif Is_Task_Allocation_Block then | |
2411 | ||
2412 | -- Add a call to Expunge_Unactivated_Tasks to the cleanup | |
2413 | -- handler of a block created for the dynamic allocation of | |
2414 | -- tasks: | |
2415 | ||
2416 | -- Expunge_Unactivated_Tasks (_chain); | |
2417 | ||
2418 | -- where _chain is the list of tasks created by the allocator | |
2419 | -- but not yet activated. This list will be empty unless | |
2420 | -- the block completes abnormally. | |
2421 | ||
2422 | -- This only applies to dynamically allocated tasks; | |
2423 | -- other unactivated tasks are completed by Complete_Task or | |
2424 | -- Complete_Master. | |
2425 | ||
2426 | -- NOTE: This cleanup handler references _chain, a local | |
2427 | -- object. | |
2428 | ||
2429 | Append_To (Stmt, | |
2430 | Make_Procedure_Call_Statement (Loc, | |
2431 | Name => | |
2432 | New_Reference_To ( | |
2433 | RTE (RE_Expunge_Unactivated_Tasks), Loc), | |
2434 | Parameter_Associations => New_List ( | |
2435 | New_Reference_To (Activation_Chain_Entity (N), Loc)))); | |
2436 | ||
2437 | elsif Is_Asynchronous_Call_Block then | |
2438 | ||
2439 | -- Add a call to attempt to cancel the asynchronous entry call | |
2440 | -- whenever the block containing the abortable part is exited. | |
2441 | ||
2442 | -- NOTE: This cleanup handler references C, a local object | |
2443 | ||
2444 | -- Get the argument to the Cancel procedure | |
2445 | Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N))); | |
2446 | ||
2447 | -- If it is of type Communication_Block, this must be a | |
2448 | -- protected entry call. | |
2449 | ||
2450 | if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then | |
2451 | ||
2452 | Append_To (Stmt, | |
2453 | ||
2454 | -- if Enqueued (Cancel_Parameter) then | |
2455 | ||
2456 | Make_Implicit_If_Statement (Clean, | |
2457 | Condition => Make_Function_Call (Loc, | |
2458 | Name => New_Reference_To ( | |
2459 | RTE (RE_Enqueued), Loc), | |
2460 | Parameter_Associations => New_List ( | |
2461 | New_Reference_To (Cancel_Param, Loc))), | |
2462 | Then_Statements => New_List ( | |
2463 | ||
2464 | -- Cancel_Protected_Entry_Call (Cancel_Param); | |
2465 | ||
2466 | Make_Procedure_Call_Statement (Loc, | |
2467 | Name => New_Reference_To ( | |
2468 | RTE (RE_Cancel_Protected_Entry_Call), Loc), | |
2469 | Parameter_Associations => New_List ( | |
2470 | New_Reference_To (Cancel_Param, Loc)))))); | |
2471 | ||
2472 | -- Asynchronous delay | |
2473 | ||
2474 | elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then | |
2475 | Append_To (Stmt, | |
2476 | Make_Procedure_Call_Statement (Loc, | |
2477 | Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc), | |
2478 | Parameter_Associations => New_List ( | |
2479 | Make_Attribute_Reference (Loc, | |
2480 | Prefix => New_Reference_To (Cancel_Param, Loc), | |
2481 | Attribute_Name => Name_Unchecked_Access)))); | |
2482 | ||
2483 | -- Task entry call | |
2484 | ||
2485 | else | |
2486 | -- Append call to Cancel_Task_Entry_Call (C); | |
2487 | ||
2488 | Append_To (Stmt, | |
2489 | Make_Procedure_Call_Statement (Loc, | |
2490 | Name => New_Reference_To ( | |
2491 | RTE (RE_Cancel_Task_Entry_Call), | |
2492 | Loc), | |
2493 | Parameter_Associations => New_List ( | |
2494 | New_Reference_To (Cancel_Param, Loc)))); | |
2495 | ||
2496 | end if; | |
2497 | end if; | |
2498 | ||
2499 | if Present (Flist) then | |
2500 | Append_To (Stmt, | |
2501 | Make_Procedure_Call_Statement (Loc, | |
2502 | Name => New_Reference_To (RTE (RE_Finalize_List), Loc), | |
2503 | Parameter_Associations => New_List ( | |
2504 | New_Reference_To (Flist, Loc)))); | |
2505 | end if; | |
2506 | ||
2507 | if Present (Mark) then | |
2508 | Append_To (Stmt, | |
2509 | Make_Procedure_Call_Statement (Loc, | |
2510 | Name => New_Reference_To (RTE (RE_SS_Release), Loc), | |
2511 | Parameter_Associations => New_List ( | |
2512 | New_Reference_To (Mark, Loc)))); | |
2513 | end if; | |
2514 | ||
dcfa065d GD |
2515 | if Present (Chained_Cleanup_Action) then |
2516 | Append_To (Stmt, | |
2517 | Make_Procedure_Call_Statement (Loc, | |
2518 | Name => Chained_Cleanup_Action)); | |
2519 | end if; | |
2520 | ||
70482933 RK |
2521 | Sbody := |
2522 | Make_Subprogram_Body (Loc, | |
2523 | Specification => | |
2524 | Make_Procedure_Specification (Loc, | |
2525 | Defining_Unit_Name => Clean), | |
2526 | ||
2527 | Declarations => New_List, | |
2528 | ||
2529 | Handled_Statement_Sequence => | |
2530 | Make_Handled_Sequence_Of_Statements (Loc, | |
2531 | Statements => Stmt)); | |
2532 | ||
2533 | if Present (Flist) or else Is_Task or else Is_Master then | |
2534 | Wrap_Cleanup_Procedure (Sbody); | |
2535 | end if; | |
2536 | ||
2537 | -- We do not want debug information for _Clean routines, | |
2538 | -- since it just confuses the debugging operation unless | |
2539 | -- we are debugging generated code. | |
2540 | ||
2541 | if not Debug_Generated_Code then | |
2542 | Set_Debug_Info_Off (Clean, True); | |
2543 | end if; | |
2544 | ||
2545 | return Sbody; | |
2546 | end Make_Clean; | |
2547 | ||
2548 | -------------------------- | |
2549 | -- Make_Deep_Array_Body -- | |
2550 | -------------------------- | |
2551 | ||
2552 | -- Array components are initialized and adjusted in the normal order | |
2553 | -- and finalized in the reverse order. Exceptions are handled and | |
2554 | -- Program_Error is re-raise in the Adjust and Finalize case | |
2555 | -- (RM 7.6.1(12)). Generate the following code : | |
2556 | -- | |
2557 | -- procedure Deep_<P> -- with <P> being Initialize or Adjust or Finalize | |
2558 | -- (L : in out Finalizable_Ptr; | |
2559 | -- V : in out Typ) | |
2560 | -- is | |
2561 | -- begin | |
2562 | -- for J1 in Typ'First (1) .. Typ'Last (1) loop | |
2563 | -- ^ reverse ^ -- in the finalization case | |
2564 | -- ... | |
2565 | -- for J2 in Typ'First (n) .. Typ'Last (n) loop | |
2566 | -- Make_<P>_Call (Typ, V (J1, .. , Jn), L, V); | |
2567 | -- end loop; | |
2568 | -- ... | |
2569 | -- end loop; | |
2570 | -- exception -- not in the | |
2571 | -- when others => raise Program_Error; -- Initialize case | |
2572 | -- end Deep_<P>; | |
2573 | ||
2574 | function Make_Deep_Array_Body | |
2575 | (Prim : Final_Primitives; | |
15ce9ca2 | 2576 | Typ : Entity_Id) return List_Id |
70482933 RK |
2577 | is |
2578 | Loc : constant Source_Ptr := Sloc (Typ); | |
2579 | ||
2580 | Index_List : constant List_Id := New_List; | |
2581 | -- Stores the list of references to the indexes (one per dimension) | |
2582 | ||
2583 | function One_Component return List_Id; | |
2584 | -- Create one statement to initialize/adjust/finalize one array | |
3b42c566 | 2585 | -- component, designated by a full set of indexes. |
70482933 RK |
2586 | |
2587 | function One_Dimension (N : Int) return List_Id; | |
2588 | -- Create loop to deal with one dimension of the array. The single | |
2589 | -- statement in the body of the loop initializes the inner dimensions if | |
2590 | -- any, or else a single component. | |
2591 | ||
2592 | ------------------- | |
2593 | -- One_Component -- | |
2594 | ------------------- | |
2595 | ||
2596 | function One_Component return List_Id is | |
2597 | Comp_Typ : constant Entity_Id := Component_Type (Typ); | |
2598 | Comp_Ref : constant Node_Id := | |
2599 | Make_Indexed_Component (Loc, | |
2600 | Prefix => Make_Identifier (Loc, Name_V), | |
2601 | Expressions => Index_List); | |
2602 | ||
2603 | begin | |
2604 | -- Set the etype of the component Reference, which is used to | |
2605 | -- determine whether a conversion to a parent type is needed. | |
2606 | ||
2607 | Set_Etype (Comp_Ref, Comp_Typ); | |
2608 | ||
2609 | case Prim is | |
2610 | when Initialize_Case => | |
2611 | return Make_Init_Call (Comp_Ref, Comp_Typ, | |
2612 | Make_Identifier (Loc, Name_L), | |
2613 | Make_Identifier (Loc, Name_B)); | |
2614 | ||
2615 | when Adjust_Case => | |
2616 | return Make_Adjust_Call (Comp_Ref, Comp_Typ, | |
2617 | Make_Identifier (Loc, Name_L), | |
2618 | Make_Identifier (Loc, Name_B)); | |
2619 | ||
2620 | when Finalize_Case => | |
2621 | return Make_Final_Call (Comp_Ref, Comp_Typ, | |
2622 | Make_Identifier (Loc, Name_B)); | |
2623 | end case; | |
2624 | end One_Component; | |
2625 | ||
2626 | ------------------- | |
2627 | -- One_Dimension -- | |
2628 | ------------------- | |
2629 | ||
2630 | function One_Dimension (N : Int) return List_Id is | |
2631 | Index : Entity_Id; | |
2632 | ||
2633 | begin | |
2634 | if N > Number_Dimensions (Typ) then | |
2635 | return One_Component; | |
2636 | ||
2637 | else | |
2638 | Index := | |
2639 | Make_Defining_Identifier (Loc, New_External_Name ('J', N)); | |
2640 | ||
2641 | Append_To (Index_List, New_Reference_To (Index, Loc)); | |
2642 | ||
2643 | return New_List ( | |
2644 | Make_Implicit_Loop_Statement (Typ, | |
2645 | Identifier => Empty, | |
2646 | Iteration_Scheme => | |
2647 | Make_Iteration_Scheme (Loc, | |
2648 | Loop_Parameter_Specification => | |
2649 | Make_Loop_Parameter_Specification (Loc, | |
2650 | Defining_Identifier => Index, | |
2651 | Discrete_Subtype_Definition => | |
2652 | Make_Attribute_Reference (Loc, | |
7675ad4f | 2653 | Prefix => Make_Identifier (Loc, Name_V), |
70482933 | 2654 | Attribute_Name => Name_Range, |
7675ad4f | 2655 | Expressions => New_List ( |
70482933 RK |
2656 | Make_Integer_Literal (Loc, N))), |
2657 | Reverse_Present => Prim = Finalize_Case)), | |
2658 | Statements => One_Dimension (N + 1))); | |
2659 | end if; | |
2660 | end One_Dimension; | |
2661 | ||
2662 | -- Start of processing for Make_Deep_Array_Body | |
2663 | ||
2664 | begin | |
2665 | return One_Dimension (1); | |
2666 | end Make_Deep_Array_Body; | |
2667 | ||
2668 | -------------------- | |
2669 | -- Make_Deep_Proc -- | |
2670 | -------------------- | |
2671 | ||
2672 | -- Generate: | |
2673 | -- procedure DEEP_<prim> | |
2674 | -- (L : IN OUT Finalizable_Ptr; -- not for Finalize | |
2675 | -- V : IN OUT <typ>; | |
2676 | -- B : IN Short_Short_Integer) is | |
2677 | -- begin | |
2678 | -- <stmts>; | |
2679 | -- exception -- Finalize and Adjust Cases only | |
2680 | -- raise Program_Error; -- idem | |
2681 | -- end DEEP_<prim>; | |
2682 | ||
2683 | function Make_Deep_Proc | |
2684 | (Prim : Final_Primitives; | |
2685 | Typ : Entity_Id; | |
15ce9ca2 | 2686 | Stmts : List_Id) return Entity_Id |
70482933 RK |
2687 | is |
2688 | Loc : constant Source_Ptr := Sloc (Typ); | |
2689 | Formals : List_Id; | |
2690 | Proc_Name : Entity_Id; | |
2691 | Handler : List_Id := No_List; | |
70482933 RK |
2692 | Type_B : Entity_Id; |
2693 | ||
2694 | begin | |
2695 | if Prim = Finalize_Case then | |
2696 | Formals := New_List; | |
2697 | Type_B := Standard_Boolean; | |
2698 | ||
2699 | else | |
2700 | Formals := New_List ( | |
2701 | Make_Parameter_Specification (Loc, | |
2702 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), | |
2703 | In_Present => True, | |
2704 | Out_Present => True, | |
2705 | Parameter_Type => | |
2706 | New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); | |
2707 | Type_B := Standard_Short_Short_Integer; | |
2708 | end if; | |
2709 | ||
2710 | Append_To (Formals, | |
2711 | Make_Parameter_Specification (Loc, | |
fbf5a39b | 2712 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), |
70482933 RK |
2713 | In_Present => True, |
2714 | Out_Present => True, | |
2715 | Parameter_Type => New_Reference_To (Typ, Loc))); | |
2716 | ||
2717 | Append_To (Formals, | |
2718 | Make_Parameter_Specification (Loc, | |
2719 | Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), | |
2720 | Parameter_Type => New_Reference_To (Type_B, Loc))); | |
2721 | ||
2722 | if Prim = Finalize_Case or else Prim = Adjust_Case then | |
dbe13a37 | 2723 | Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc)); |
70482933 RK |
2724 | end if; |
2725 | ||
fbf5a39b AC |
2726 | Proc_Name := |
2727 | Make_Defining_Identifier (Loc, | |
2728 | Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim))); | |
70482933 | 2729 | |
fbf5a39b | 2730 | Discard_Node ( |
70482933 RK |
2731 | Make_Subprogram_Body (Loc, |
2732 | Specification => | |
2733 | Make_Procedure_Specification (Loc, | |
2734 | Defining_Unit_Name => Proc_Name, | |
2735 | Parameter_Specifications => Formals), | |
2736 | ||
2737 | Declarations => Empty_List, | |
2738 | Handled_Statement_Sequence => | |
2739 | Make_Handled_Sequence_Of_Statements (Loc, | |
2740 | Statements => Stmts, | |
fbf5a39b | 2741 | Exception_Handlers => Handler))); |
70482933 RK |
2742 | |
2743 | return Proc_Name; | |
2744 | end Make_Deep_Proc; | |
2745 | ||
2746 | --------------------------- | |
2747 | -- Make_Deep_Record_Body -- | |
2748 | --------------------------- | |
2749 | ||
2750 | -- The Deep procedures call the appropriate Controlling proc on the | |
308e6f3a | 2751 | -- controller component. In the init case, it also attach the |
70482933 RK |
2752 | -- controller to the current finalization list. |
2753 | ||
2754 | function Make_Deep_Record_Body | |
2755 | (Prim : Final_Primitives; | |
15ce9ca2 | 2756 | Typ : Entity_Id) return List_Id |
70482933 RK |
2757 | is |
2758 | Loc : constant Source_Ptr := Sloc (Typ); | |
2759 | Controller_Typ : Entity_Id; | |
2760 | Obj_Ref : constant Node_Id := Make_Identifier (Loc, Name_V); | |
2761 | Controller_Ref : constant Node_Id := | |
2762 | Make_Selected_Component (Loc, | |
2763 | Prefix => Obj_Ref, | |
2764 | Selector_Name => | |
2765 | Make_Identifier (Loc, Name_uController)); | |
fbf5a39b | 2766 | Res : constant List_Id := New_List; |
70482933 RK |
2767 | |
2768 | begin | |
40f07b4b | 2769 | if Is_Immutably_Limited_Type (Typ) then |
70482933 RK |
2770 | Controller_Typ := RTE (RE_Limited_Record_Controller); |
2771 | else | |
2772 | Controller_Typ := RTE (RE_Record_Controller); | |
2773 | end if; | |
2774 | ||
2775 | case Prim is | |
2776 | when Initialize_Case => | |
fbf5a39b AC |
2777 | Append_List_To (Res, |
2778 | Make_Init_Call ( | |
2779 | Ref => Controller_Ref, | |
2780 | Typ => Controller_Typ, | |
2781 | Flist_Ref => Make_Identifier (Loc, Name_L), | |
2782 | With_Attach => Make_Identifier (Loc, Name_B))); | |
2783 | ||
2784 | -- When the type is also a controlled type by itself, | |
16b05213 | 2785 | -- initialize it and attach it to the finalization chain. |
fbf5a39b AC |
2786 | |
2787 | if Is_Controlled (Typ) then | |
2788 | Append_To (Res, | |
2789 | Make_Procedure_Call_Statement (Loc, | |
2790 | Name => New_Reference_To ( | |
2791 | Find_Prim_Op (Typ, Name_Of (Prim)), Loc), | |
2792 | Parameter_Associations => | |
2793 | New_List (New_Copy_Tree (Obj_Ref)))); | |
2794 | ||
7675ad4f AC |
2795 | Append_To (Res, |
2796 | Make_Attach_Call | |
2797 | (Obj_Ref => New_Copy_Tree (Obj_Ref), | |
2798 | Flist_Ref => Make_Identifier (Loc, Name_L), | |
2799 | With_Attach => Make_Identifier (Loc, Name_B))); | |
fbf5a39b | 2800 | end if; |
70482933 RK |
2801 | |
2802 | when Adjust_Case => | |
fbf5a39b | 2803 | Append_List_To (Res, |
7675ad4f AC |
2804 | Make_Adjust_Call |
2805 | (Controller_Ref, Controller_Typ, | |
2806 | Make_Identifier (Loc, Name_L), | |
2807 | Make_Identifier (Loc, Name_B))); | |
fbf5a39b AC |
2808 | |
2809 | -- When the type is also a controlled type by itself, | |
16b05213 | 2810 | -- adjust it and attach it to the finalization chain. |
fbf5a39b AC |
2811 | |
2812 | if Is_Controlled (Typ) then | |
2813 | Append_To (Res, | |
2814 | Make_Procedure_Call_Statement (Loc, | |
2815 | Name => New_Reference_To ( | |
2816 | Find_Prim_Op (Typ, Name_Of (Prim)), Loc), | |
2817 | Parameter_Associations => | |
2818 | New_List (New_Copy_Tree (Obj_Ref)))); | |
2819 | ||
7675ad4f AC |
2820 | Append_To (Res, |
2821 | Make_Attach_Call | |
2822 | (Obj_Ref => New_Copy_Tree (Obj_Ref), | |
2823 | Flist_Ref => Make_Identifier (Loc, Name_L), | |
2824 | With_Attach => Make_Identifier (Loc, Name_B))); | |
fbf5a39b | 2825 | end if; |
70482933 RK |
2826 | |
2827 | when Finalize_Case => | |
fbf5a39b AC |
2828 | if Is_Controlled (Typ) then |
2829 | Append_To (Res, | |
2830 | Make_Implicit_If_Statement (Obj_Ref, | |
7675ad4f | 2831 | Condition => Make_Identifier (Loc, Name_B), |
fbf5a39b AC |
2832 | Then_Statements => New_List ( |
2833 | Make_Procedure_Call_Statement (Loc, | |
2834 | Name => New_Reference_To (RTE (RE_Finalize_One), Loc), | |
2835 | Parameter_Associations => New_List ( | |
2836 | OK_Convert_To (RTE (RE_Finalizable), | |
2837 | New_Copy_Tree (Obj_Ref))))), | |
2838 | ||
2839 | Else_Statements => New_List ( | |
2840 | Make_Procedure_Call_Statement (Loc, | |
2841 | Name => New_Reference_To ( | |
2842 | Find_Prim_Op (Typ, Name_Of (Prim)), Loc), | |
2843 | Parameter_Associations => | |
2844 | New_List (New_Copy_Tree (Obj_Ref)))))); | |
2845 | end if; | |
2846 | ||
2847 | Append_List_To (Res, | |
7675ad4f AC |
2848 | Make_Final_Call |
2849 | (Controller_Ref, Controller_Typ, | |
2850 | Make_Identifier (Loc, Name_B))); | |
70482933 | 2851 | end case; |
7675ad4f | 2852 | |
fbf5a39b | 2853 | return Res; |
70482933 RK |
2854 | end Make_Deep_Record_Body; |
2855 | ||
2856 | ---------------------- | |
2857 | -- Make_Final_Call -- | |
2858 | ---------------------- | |
2859 | ||
2860 | function Make_Final_Call | |
2861 | (Ref : Node_Id; | |
2862 | Typ : Entity_Id; | |
15ce9ca2 | 2863 | With_Detach : Node_Id) return List_Id |
70482933 RK |
2864 | is |
2865 | Loc : constant Source_Ptr := Sloc (Ref); | |
2866 | Res : constant List_Id := New_List; | |
2867 | Cref : Node_Id; | |
2868 | Cref2 : Node_Id; | |
2869 | Proc : Entity_Id; | |
2870 | Utyp : Entity_Id; | |
2871 | ||
2872 | begin | |
2873 | if Is_Class_Wide_Type (Typ) then | |
2874 | Utyp := Root_Type (Typ); | |
2875 | Cref := Ref; | |
2876 | ||
2877 | elsif Is_Concurrent_Type (Typ) then | |
2878 | Utyp := Corresponding_Record_Type (Typ); | |
2879 | Cref := Convert_Concurrent (Ref, Typ); | |
2880 | ||
2881 | elsif Is_Private_Type (Typ) | |
2882 | and then Present (Full_View (Typ)) | |
2883 | and then Is_Concurrent_Type (Full_View (Typ)) | |
2884 | then | |
2885 | Utyp := Corresponding_Record_Type (Full_View (Typ)); | |
2886 | Cref := Convert_Concurrent (Ref, Full_View (Typ)); | |
2887 | else | |
2888 | Utyp := Typ; | |
2889 | Cref := Ref; | |
2890 | end if; | |
2891 | ||
2892 | Utyp := Underlying_Type (Base_Type (Utyp)); | |
2893 | Set_Assignment_OK (Cref); | |
2894 | ||
f4d379b8 HK |
2895 | -- Deal with non-tagged derivation of private views. If the parent is |
2896 | -- now known to be protected, the finalization routine is the one | |
2897 | -- defined on the corresponding record of the ancestor (corresponding | |
2898 | -- records do not automatically inherit operations, but maybe they | |
2899 | -- should???) | |
70482933 RK |
2900 | |
2901 | if Is_Untagged_Derivation (Typ) then | |
f4d379b8 HK |
2902 | if Is_Protected_Type (Typ) then |
2903 | Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); | |
2904 | else | |
2905 | Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); | |
2906 | end if; | |
2907 | ||
70482933 | 2908 | Cref := Unchecked_Convert_To (Utyp, Cref); |
f4d379b8 HK |
2909 | |
2910 | -- We need to set Assignment_OK to prevent problems with unchecked | |
2911 | -- conversions, where we do not want them to be converted back in the | |
2912 | -- case of untagged record derivation (see code in Make_*_Call | |
2913 | -- procedures for similar situations). | |
2914 | ||
70482933 | 2915 | Set_Assignment_OK (Cref); |
70482933 RK |
2916 | end if; |
2917 | ||
2918 | -- If the underlying_type is a subtype, we are dealing with | |
2919 | -- the completion of a private type. We need to access | |
2920 | -- the base type and generate a conversion to it. | |
2921 | ||
2922 | if Utyp /= Base_Type (Utyp) then | |
2923 | pragma Assert (Is_Private_Type (Typ)); | |
2924 | Utyp := Base_Type (Utyp); | |
2925 | Cref := Unchecked_Convert_To (Utyp, Cref); | |
2926 | end if; | |
2927 | ||
2928 | -- Generate: | |
2929 | -- Deep_Finalize (Ref, With_Detach); | |
2930 | ||
2931 | if Has_Controlled_Component (Utyp) | |
2932 | or else Is_Class_Wide_Type (Typ) | |
2933 | then | |
2934 | if Is_Tagged_Type (Utyp) then | |
fbf5a39b | 2935 | Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize); |
70482933 | 2936 | else |
fbf5a39b | 2937 | Proc := TSS (Utyp, TSS_Deep_Finalize); |
70482933 RK |
2938 | end if; |
2939 | ||
2940 | Cref := Convert_View (Proc, Cref); | |
2941 | ||
2942 | Append_To (Res, | |
2943 | Make_Procedure_Call_Statement (Loc, | |
2944 | Name => New_Reference_To (Proc, Loc), | |
2945 | Parameter_Associations => | |
2946 | New_List (Cref, With_Detach))); | |
2947 | ||
2948 | -- Generate: | |
2949 | -- if With_Detach then | |
2950 | -- Finalize_One (Ref); | |
2951 | -- else | |
2952 | -- Finalize (Ref); | |
2953 | -- end if; | |
2954 | ||
2955 | else | |
2956 | Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case)); | |
2957 | ||
2958 | if Chars (With_Detach) = Chars (Standard_True) then | |
2959 | Append_To (Res, | |
2960 | Make_Procedure_Call_Statement (Loc, | |
2961 | Name => New_Reference_To (RTE (RE_Finalize_One), Loc), | |
2962 | Parameter_Associations => New_List ( | |
2963 | OK_Convert_To (RTE (RE_Finalizable), Cref)))); | |
2964 | ||
2965 | elsif Chars (With_Detach) = Chars (Standard_False) then | |
2966 | Append_To (Res, | |
2967 | Make_Procedure_Call_Statement (Loc, | |
2968 | Name => New_Reference_To (Proc, Loc), | |
2969 | Parameter_Associations => | |
2970 | New_List (Convert_View (Proc, Cref)))); | |
2971 | ||
2972 | else | |
2973 | Cref2 := New_Copy_Tree (Cref); | |
2974 | Append_To (Res, | |
2975 | Make_Implicit_If_Statement (Ref, | |
2976 | Condition => With_Detach, | |
2977 | Then_Statements => New_List ( | |
2978 | Make_Procedure_Call_Statement (Loc, | |
2979 | Name => New_Reference_To (RTE (RE_Finalize_One), Loc), | |
2980 | Parameter_Associations => New_List ( | |
2981 | OK_Convert_To (RTE (RE_Finalizable), Cref)))), | |
2982 | ||
2983 | Else_Statements => New_List ( | |
2984 | Make_Procedure_Call_Statement (Loc, | |
2985 | Name => New_Reference_To (Proc, Loc), | |
2986 | Parameter_Associations => | |
2987 | New_List (Convert_View (Proc, Cref2)))))); | |
2988 | end if; | |
2989 | end if; | |
2990 | ||
70482933 RK |
2991 | return Res; |
2992 | end Make_Final_Call; | |
2993 | ||
dbe13a37 ES |
2994 | ------------------------------------- |
2995 | -- Make_Handler_For_Ctrl_Operation -- | |
2996 | ------------------------------------- | |
2997 | ||
2998 | -- Generate: | |
2999 | ||
3000 | -- when E : others => | |
3001 | -- Raise_From_Controlled_Operation (X => E); | |
3002 | ||
3003 | -- or: | |
3004 | ||
3005 | -- when others => | |
3006 | -- raise Program_Error [finalize raised exception]; | |
3007 | ||
3008 | -- depending on whether Raise_From_Controlled_Operation is available | |
3009 | ||
3010 | function Make_Handler_For_Ctrl_Operation | |
3011 | (Loc : Source_Ptr) return Node_Id | |
3012 | is | |
3013 | E_Occ : Entity_Id; | |
3014 | -- Choice parameter (for the first case above) | |
3015 | ||
3016 | Raise_Node : Node_Id; | |
3017 | -- Procedure call or raise statement | |
3018 | ||
3019 | begin | |
3020 | if RTE_Available (RE_Raise_From_Controlled_Operation) then | |
3021 | ||
3022 | -- Standard runtime: add choice parameter E, and pass it to | |
3023 | -- Raise_From_Controlled_Operation so that the original exception | |
3024 | -- name and message can be recorded in the exception message for | |
3025 | -- Program_Error. | |
3026 | ||
3027 | E_Occ := Make_Defining_Identifier (Loc, Name_E); | |
3028 | Raise_Node := Make_Procedure_Call_Statement (Loc, | |
3029 | Name => | |
3030 | New_Occurrence_Of ( | |
3031 | RTE (RE_Raise_From_Controlled_Operation), Loc), | |
3032 | Parameter_Associations => New_List ( | |
3033 | New_Occurrence_Of (E_Occ, Loc))); | |
3034 | ||
3035 | else | |
3036 | -- Restricted runtime: exception messages are not supported | |
3037 | ||
3038 | E_Occ := Empty; | |
3039 | Raise_Node := Make_Raise_Program_Error (Loc, | |
3040 | Reason => PE_Finalize_Raised_Exception); | |
3041 | end if; | |
3042 | ||
3043 | return Make_Implicit_Exception_Handler (Loc, | |
3044 | Exception_Choices => New_List (Make_Others_Choice (Loc)), | |
3045 | Choice_Parameter => E_Occ, | |
3046 | Statements => New_List (Raise_Node)); | |
3047 | end Make_Handler_For_Ctrl_Operation; | |
3048 | ||
70482933 RK |
3049 | -------------------- |
3050 | -- Make_Init_Call -- | |
3051 | -------------------- | |
3052 | ||
3053 | function Make_Init_Call | |
3054 | (Ref : Node_Id; | |
3055 | Typ : Entity_Id; | |
3056 | Flist_Ref : Node_Id; | |
15ce9ca2 | 3057 | With_Attach : Node_Id) return List_Id |
70482933 RK |
3058 | is |
3059 | Loc : constant Source_Ptr := Sloc (Ref); | |
3060 | Is_Conc : Boolean; | |
3061 | Res : constant List_Id := New_List; | |
3062 | Proc : Entity_Id; | |
3063 | Utyp : Entity_Id; | |
3064 | Cref : Node_Id; | |
3065 | Cref2 : Node_Id; | |
3066 | Attach : Node_Id := With_Attach; | |
3067 | ||
3068 | begin | |
3069 | if Is_Concurrent_Type (Typ) then | |
3070 | Is_Conc := True; | |
3071 | Utyp := Corresponding_Record_Type (Typ); | |
3072 | Cref := Convert_Concurrent (Ref, Typ); | |
3073 | ||
3074 | elsif Is_Private_Type (Typ) | |
3075 | and then Present (Full_View (Typ)) | |
3076 | and then Is_Concurrent_Type (Underlying_Type (Typ)) | |
3077 | then | |
3078 | Is_Conc := True; | |
3079 | Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); | |
3080 | Cref := Convert_Concurrent (Ref, Underlying_Type (Typ)); | |
3081 | ||
3082 | else | |
3083 | Is_Conc := False; | |
3084 | Utyp := Typ; | |
3085 | Cref := Ref; | |
3086 | end if; | |
3087 | ||
3088 | Utyp := Underlying_Type (Base_Type (Utyp)); | |
3089 | ||
3090 | Set_Assignment_OK (Cref); | |
3091 | ||
3092 | -- Deal with non-tagged derivation of private views | |
3093 | ||
3094 | if Is_Untagged_Derivation (Typ) | |
3095 | and then not Is_Conc | |
3096 | then | |
3097 | Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); | |
3098 | Cref := Unchecked_Convert_To (Utyp, Cref); | |
3099 | Set_Assignment_OK (Cref); | |
3100 | -- To prevent problems with UC see 1.156 RH ??? | |
3101 | end if; | |
3102 | ||
3103 | -- If the underlying_type is a subtype, we are dealing with | |
3104 | -- the completion of a private type. We need to access | |
3105 | -- the base type and generate a conversion to it. | |
3106 | ||
3107 | if Utyp /= Base_Type (Utyp) then | |
3108 | pragma Assert (Is_Private_Type (Typ)); | |
3109 | Utyp := Base_Type (Utyp); | |
3110 | Cref := Unchecked_Convert_To (Utyp, Cref); | |
3111 | end if; | |
3112 | ||
3113 | -- We do not need to attach to one of the Global Final Lists | |
3114 | -- the objects whose type is Finalize_Storage_Only | |
3115 | ||
3116 | if Finalize_Storage_Only (Typ) | |
3117 | and then (Global_Flist_Ref (Flist_Ref) | |
3118 | or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) | |
3119 | = Standard_True) | |
3120 | then | |
3121 | Attach := Make_Integer_Literal (Loc, 0); | |
3122 | end if; | |
3123 | ||
3124 | -- Generate: | |
3125 | -- Deep_Initialize (Ref, Flist_Ref); | |
3126 | ||
3127 | if Has_Controlled_Component (Utyp) then | |
3128 | Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case)); | |
3129 | ||
3130 | Cref := Convert_View (Proc, Cref, 2); | |
3131 | ||
3132 | Append_To (Res, | |
3133 | Make_Procedure_Call_Statement (Loc, | |
3134 | Name => New_Reference_To (Proc, Loc), | |
3135 | Parameter_Associations => New_List ( | |
3136 | Node1 => Flist_Ref, | |
3137 | Node2 => Cref, | |
3138 | Node3 => Attach))); | |
3139 | ||
3140 | -- Generate: | |
3141 | -- Attach_To_Final_List (Ref, Flist_Ref); | |
3142 | -- Initialize (Ref); | |
3143 | ||
3144 | else -- Is_Controlled (Utyp) | |
3145 | Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case)); | |
fbf5a39b AC |
3146 | Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref); |
3147 | ||
70482933 RK |
3148 | Cref := Convert_View (Proc, Cref); |
3149 | Cref2 := New_Copy_Tree (Cref); | |
3150 | ||
3151 | Append_To (Res, | |
3152 | Make_Procedure_Call_Statement (Loc, | |
3153 | Name => New_Reference_To (Proc, Loc), | |
3154 | Parameter_Associations => New_List (Cref2))); | |
3155 | ||
3156 | Append_To (Res, | |
3157 | Make_Attach_Call (Cref, Flist_Ref, Attach)); | |
70482933 RK |
3158 | end if; |
3159 | ||
3160 | return Res; | |
3161 | end Make_Init_Call; | |
3162 | ||
3163 | -------------------------- | |
3164 | -- Make_Transient_Block -- | |
3165 | -------------------------- | |
3166 | ||
3167 | -- If finalization is involved, this function just wraps the instruction | |
3168 | -- into a block whose name is the transient block entity, and then | |
3169 | -- Expand_Cleanup_Actions (called on the expansion of the handled | |
3170 | -- sequence of statements will do the necessary expansions for | |
3171 | -- cleanups). | |
3172 | ||
3173 | function Make_Transient_Block | |
3174 | (Loc : Source_Ptr; | |
15ce9ca2 | 3175 | Action : Node_Id) return Node_Id |
70482933 RK |
3176 | is |
3177 | Flist : constant Entity_Id := Finalization_Chain_Entity (Current_Scope); | |
3178 | Decls : constant List_Id := New_List; | |
9e2b9627 | 3179 | Par : constant Node_Id := Parent (Action); |
70482933 RK |
3180 | Instrs : constant List_Id := New_List (Action); |
3181 | Blk : Node_Id; | |
3182 | ||
3183 | begin | |
3184 | -- Case where only secondary stack use is involved | |
3185 | ||
dbe13a37 ES |
3186 | if VM_Target = No_VM |
3187 | and then Uses_Sec_Stack (Current_Scope) | |
70482933 | 3188 | and then No (Flist) |
33c423c8 | 3189 | and then Nkind (Action) /= N_Simple_Return_Statement |
9e2b9627 | 3190 | and then Nkind (Par) /= N_Exception_Handler |
70482933 | 3191 | then |
70482933 RK |
3192 | declare |
3193 | S : Entity_Id; | |
3194 | K : Entity_Kind; | |
c1fd002c | 3195 | |
70482933 RK |
3196 | begin |
3197 | S := Scope (Current_Scope); | |
3198 | loop | |
3199 | K := Ekind (S); | |
3200 | ||
3201 | -- At the outer level, no need to release the sec stack | |
3202 | ||
3203 | if S = Standard_Standard then | |
3204 | Set_Uses_Sec_Stack (Current_Scope, False); | |
3205 | exit; | |
3206 | ||
3207 | -- In a function, only release the sec stack if the | |
3208 | -- function does not return on the sec stack otherwise | |
3209 | -- the result may be lost. The caller is responsible for | |
3210 | -- releasing. | |
3211 | ||
3212 | elsif K = E_Function then | |
3213 | Set_Uses_Sec_Stack (Current_Scope, False); | |
3214 | ||
3215 | if not Requires_Transient_Scope (Etype (S)) then | |
afe4375b ES |
3216 | Set_Uses_Sec_Stack (S, True); |
3217 | Check_Restriction (No_Secondary_Stack, Action); | |
70482933 RK |
3218 | end if; |
3219 | ||
3220 | exit; | |
3221 | ||
3222 | -- In a loop or entry we should install a block encompassing | |
3223 | -- all the construct. For now just release right away. | |
3224 | ||
3225 | elsif K = E_Loop or else K = E_Entry then | |
3226 | exit; | |
3227 | ||
3228 | -- In a procedure or a block, we release on exit of the | |
3229 | -- procedure or block. ??? memory leak can be created by | |
3230 | -- recursive calls. | |
3231 | ||
3232 | elsif K = E_Procedure | |
3233 | or else K = E_Block | |
3234 | then | |
afe4375b ES |
3235 | Set_Uses_Sec_Stack (S, True); |
3236 | Check_Restriction (No_Secondary_Stack, Action); | |
70482933 RK |
3237 | Set_Uses_Sec_Stack (Current_Scope, False); |
3238 | exit; | |
3239 | ||
3240 | else | |
3241 | S := Scope (S); | |
3242 | end if; | |
3243 | end loop; | |
3244 | end; | |
3245 | end if; | |
3246 | ||
3247 | -- Insert actions stuck in the transient scopes as well as all | |
3248 | -- freezing nodes needed by those actions | |
3249 | ||
3250 | Insert_Actions_In_Scope_Around (Action); | |
3251 | ||
3252 | declare | |
3253 | Last_Inserted : Node_Id := Prev (Action); | |
70482933 RK |
3254 | begin |
3255 | if Present (Last_Inserted) then | |
3256 | Freeze_All (First_Entity (Current_Scope), Last_Inserted); | |
3257 | end if; | |
3258 | end; | |
3259 | ||
3260 | Blk := | |
3261 | Make_Block_Statement (Loc, | |
3262 | Identifier => New_Reference_To (Current_Scope, Loc), | |
3263 | Declarations => Decls, | |
3264 | Handled_Statement_Sequence => | |
3265 | Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs), | |
3266 | Has_Created_Identifier => True); | |
3267 | ||
3268 | -- When the transient scope was established, we pushed the entry for | |
3269 | -- the transient scope onto the scope stack, so that the scope was | |
3270 | -- active for the installation of finalizable entities etc. Now we | |
3271 | -- must remove this entry, since we have constructed a proper block. | |
3272 | ||
3273 | Pop_Scope; | |
3274 | ||
3275 | return Blk; | |
3276 | end Make_Transient_Block; | |
3277 | ||
c1fd002c RD |
3278 | ------------------------ |
3279 | -- Needs_Finalization -- | |
3280 | ------------------------ | |
3281 | ||
3282 | function Needs_Finalization (T : Entity_Id) return Boolean is | |
3283 | ||
3284 | function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; | |
3285 | -- If type is not frozen yet, check explicitly among its components, | |
3286 | -- because the Has_Controlled_Component flag is not necessarily set. | |
3287 | ||
3288 | ----------------------------------- | |
3289 | -- Has_Some_Controlled_Component -- | |
3290 | ----------------------------------- | |
3291 | ||
3292 | function Has_Some_Controlled_Component | |
3293 | (Rec : Entity_Id) return Boolean | |
3294 | is | |
3295 | Comp : Entity_Id; | |
3296 | ||
3297 | begin | |
3298 | if Has_Controlled_Component (Rec) then | |
3299 | return True; | |
3300 | ||
3301 | elsif not Is_Frozen (Rec) then | |
3302 | if Is_Record_Type (Rec) then | |
3303 | Comp := First_Entity (Rec); | |
3304 | ||
3305 | while Present (Comp) loop | |
3306 | if not Is_Type (Comp) | |
3307 | and then Needs_Finalization (Etype (Comp)) | |
3308 | then | |
3309 | return True; | |
3310 | end if; | |
3311 | ||
3312 | Next_Entity (Comp); | |
3313 | end loop; | |
3314 | ||
3315 | return False; | |
3316 | ||
3317 | elsif Is_Array_Type (Rec) then | |
3318 | return Needs_Finalization (Component_Type (Rec)); | |
3319 | ||
3320 | else | |
3321 | return Has_Controlled_Component (Rec); | |
3322 | end if; | |
3323 | else | |
3324 | return False; | |
3325 | end if; | |
3326 | end Has_Some_Controlled_Component; | |
3327 | ||
3328 | -- Start of processing for Needs_Finalization | |
3329 | ||
3330 | begin | |
90e9a6be AC |
3331 | return |
3332 | ||
3333 | -- Class-wide types must be treated as controlled and therefore | |
3334 | -- requiring finalization (because they may be extended with an | |
3335 | -- extension that has controlled components. | |
3336 | ||
3337 | (Is_Class_Wide_Type (T) | |
3338 | ||
3339 | -- However, avoid treating class-wide types as controlled if | |
3340 | -- finalization is not available and in particular CIL value | |
3341 | -- types never have finalization). | |
c1fd002c | 3342 | |
90e9a6be AC |
3343 | and then not In_Finalization_Root (T) |
3344 | and then not Restriction_Active (No_Finalization) | |
3345 | and then not Is_Value_Type (Etype (T))) | |
3346 | ||
3347 | -- Controlled types always need finalization | |
c1fd002c | 3348 | |
c1fd002c RD |
3349 | or else Is_Controlled (T) |
3350 | or else Has_Some_Controlled_Component (T) | |
90e9a6be AC |
3351 | |
3352 | -- For concurrent types, test the corresponding record type | |
3353 | ||
c1fd002c RD |
3354 | or else (Is_Concurrent_Type (T) |
3355 | and then Present (Corresponding_Record_Type (T)) | |
3356 | and then Needs_Finalization (Corresponding_Record_Type (T))); | |
3357 | end Needs_Finalization; | |
3358 | ||
70482933 RK |
3359 | ------------------------ |
3360 | -- Node_To_Be_Wrapped -- | |
3361 | ------------------------ | |
3362 | ||
3363 | function Node_To_Be_Wrapped return Node_Id is | |
3364 | begin | |
3365 | return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped; | |
3366 | end Node_To_Be_Wrapped; | |
3367 | ||
3368 | ---------------------------- | |
3369 | -- Set_Node_To_Be_Wrapped -- | |
3370 | ---------------------------- | |
3371 | ||
3372 | procedure Set_Node_To_Be_Wrapped (N : Node_Id) is | |
3373 | begin | |
3374 | Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N; | |
3375 | end Set_Node_To_Be_Wrapped; | |
3376 | ||
3377 | ---------------------------------- | |
3378 | -- Store_After_Actions_In_Scope -- | |
3379 | ---------------------------------- | |
3380 | ||
3381 | procedure Store_After_Actions_In_Scope (L : List_Id) is | |
3382 | SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); | |
3383 | ||
3384 | begin | |
3385 | if Present (SE.Actions_To_Be_Wrapped_After) then | |
3386 | Insert_List_Before_And_Analyze ( | |
3387 | First (SE.Actions_To_Be_Wrapped_After), L); | |
3388 | ||
3389 | else | |
3390 | SE.Actions_To_Be_Wrapped_After := L; | |
3391 | ||
3392 | if Is_List_Member (SE.Node_To_Be_Wrapped) then | |
3393 | Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); | |
3394 | else | |
3395 | Set_Parent (L, SE.Node_To_Be_Wrapped); | |
3396 | end if; | |
3397 | ||
3398 | Analyze_List (L); | |
3399 | end if; | |
3400 | end Store_After_Actions_In_Scope; | |
3401 | ||
3402 | ----------------------------------- | |
3403 | -- Store_Before_Actions_In_Scope -- | |
3404 | ----------------------------------- | |
3405 | ||
3406 | procedure Store_Before_Actions_In_Scope (L : List_Id) is | |
3407 | SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); | |
3408 | ||
3409 | begin | |
3410 | if Present (SE.Actions_To_Be_Wrapped_Before) then | |
3411 | Insert_List_After_And_Analyze ( | |
3412 | Last (SE.Actions_To_Be_Wrapped_Before), L); | |
3413 | ||
3414 | else | |
3415 | SE.Actions_To_Be_Wrapped_Before := L; | |
3416 | ||
3417 | if Is_List_Member (SE.Node_To_Be_Wrapped) then | |
3418 | Set_Parent (L, Parent (SE.Node_To_Be_Wrapped)); | |
3419 | else | |
3420 | Set_Parent (L, SE.Node_To_Be_Wrapped); | |
3421 | end if; | |
3422 | ||
3423 | Analyze_List (L); | |
3424 | end if; | |
3425 | end Store_Before_Actions_In_Scope; | |
3426 | ||
3427 | -------------------------------- | |
3428 | -- Wrap_Transient_Declaration -- | |
3429 | -------------------------------- | |
3430 | ||
3431 | -- If a transient scope has been established during the processing of the | |
3432 | -- Expression of an Object_Declaration, it is not possible to wrap the | |
3433 | -- declaration into a transient block as usual case, otherwise the object | |
3434 | -- would be itself declared in the wrong scope. Therefore, all entities (if | |
3435 | -- any) defined in the transient block are moved to the proper enclosing | |
3436 | -- scope, furthermore, if they are controlled variables they are finalized | |
3437 | -- right after the declaration. The finalization list of the transient | |
3438 | -- scope is defined as a renaming of the enclosing one so during their | |
3439 | -- initialization they will be attached to the proper finalization | |
3440 | -- list. For instance, the following declaration : | |
3441 | ||
3442 | -- X : Typ := F (G (A), G (B)); | |
3443 | ||
3444 | -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2) | |
3445 | -- is expanded into : | |
3446 | ||
3447 | -- _local_final_list_1 : Finalizable_Ptr; | |
3448 | -- X : Typ := [ complex Expression-Action ]; | |
3449 | -- Finalize_One(_v1); | |
3450 | -- Finalize_One (_v2); | |
3451 | ||
3452 | procedure Wrap_Transient_Declaration (N : Node_Id) is | |
c5288c90 | 3453 | Loc : constant Source_Ptr := Sloc (N); |
23685ae6 | 3454 | Next_N : constant Node_Id := Next (N); |
c5288c90 | 3455 | Enclosing_S : Entity_Id; |
23685ae6 AC |
3456 | First_Decl_Loc : Source_Ptr; |
3457 | LC : Entity_Id := Empty; | |
3458 | Nodes : List_Id; | |
3459 | S : Entity_Id; | |
c5288c90 | 3460 | Uses_SS : Boolean; |
23685ae6 | 3461 | |
70482933 RK |
3462 | begin |
3463 | S := Current_Scope; | |
3464 | Enclosing_S := Scope (S); | |
3465 | ||
3466 | -- Insert Actions kept in the Scope stack | |
3467 | ||
3468 | Insert_Actions_In_Scope_Around (N); | |
3469 | ||
3470 | -- If the declaration is consuming some secondary stack, mark the | |
3471 | -- Enclosing scope appropriately. | |
3472 | ||
3473 | Uses_SS := Uses_Sec_Stack (S); | |
3474 | Pop_Scope; | |
3475 | ||
3476 | -- Create a List controller and rename the final list to be its | |
3477 | -- internal final pointer: | |
3478 | -- Lxxx : Simple_List_Controller; | |
3479 | -- Fxxx : Finalizable_Ptr renames Lxxx.F; | |
3480 | ||
3481 | if Present (Finalization_Chain_Entity (S)) then | |
c12beea0 | 3482 | LC := Make_Temporary (Loc, 'L'); |
70482933 | 3483 | |
c5288c90 AC |
3484 | -- Use the Sloc of the first declaration of N's containing list, to |
3485 | -- maintain monotonicity of source-line stepping during debugging. | |
3486 | ||
3487 | First_Decl_Loc := Sloc (First (List_Containing (N))); | |
3488 | ||
70482933 | 3489 | Nodes := New_List ( |
c5288c90 | 3490 | Make_Object_Declaration (First_Decl_Loc, |
70482933 RK |
3491 | Defining_Identifier => LC, |
3492 | Object_Definition => | |
c5288c90 AC |
3493 | New_Reference_To |
3494 | (RTE (RE_Simple_List_Controller), First_Decl_Loc)), | |
70482933 | 3495 | |
c5288c90 | 3496 | Make_Object_Renaming_Declaration (First_Decl_Loc, |
70482933 | 3497 | Defining_Identifier => Finalization_Chain_Entity (S), |
c5288c90 AC |
3498 | Subtype_Mark => |
3499 | New_Reference_To (RTE (RE_Finalizable_Ptr), First_Decl_Loc), | |
70482933 RK |
3500 | Name => |
3501 | Make_Selected_Component (Loc, | |
c5288c90 AC |
3502 | Prefix => New_Reference_To (LC, First_Decl_Loc), |
3503 | Selector_Name => Make_Identifier (First_Decl_Loc, Name_F)))); | |
70482933 RK |
3504 | |
3505 | -- Put the declaration at the beginning of the declaration part | |
3506 | -- to make sure it will be before all other actions that have been | |
3507 | -- inserted before N. | |
3508 | ||
3509 | Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes); | |
3510 | ||
dcfa065d GD |
3511 | -- Generate the Finalization calls by finalizing the list controller |
3512 | -- right away. It will be re-finalized on scope exit but it doesn't | |
3513 | -- matter. It cannot be done when the call initializes a renaming | |
3514 | -- object though because in this case, the object becomes a pointer | |
3515 | -- to the temporary and thus increases its life span. Ditto if this | |
3516 | -- is a renaming of a component of an expression (such as a function | |
3517 | -- call). | |
3518 | ||
d07e197c JM |
3519 | -- Note that there is a problem if an actual in the call needs |
3520 | -- finalization, because in that case the call itself is the master, | |
3521 | -- and the actual should be finalized on return from the call ??? | |
70482933 RK |
3522 | |
3523 | if Nkind (N) = N_Object_Renaming_Declaration | |
048e5cef | 3524 | and then Needs_Finalization (Etype (Defining_Identifier (N))) |
70482933 RK |
3525 | then |
3526 | null; | |
3527 | ||
d07e197c JM |
3528 | elsif Nkind (N) = N_Object_Renaming_Declaration |
3529 | and then | |
3530 | Nkind_In (Renamed_Object (Defining_Identifier (N)), | |
3531 | N_Selected_Component, | |
3532 | N_Indexed_Component) | |
3533 | and then | |
048e5cef | 3534 | Needs_Finalization |
d07e197c JM |
3535 | (Etype (Prefix (Renamed_Object (Defining_Identifier (N))))) |
3536 | then | |
3537 | null; | |
3538 | ||
23685ae6 AC |
3539 | -- Finalize the list controller |
3540 | ||
70482933 RK |
3541 | else |
3542 | Nodes := | |
d07e197c JM |
3543 | Make_Final_Call |
3544 | (Ref => New_Reference_To (LC, Loc), | |
3545 | Typ => Etype (LC), | |
3546 | With_Detach => New_Reference_To (Standard_False, Loc)); | |
3547 | ||
70482933 RK |
3548 | if Present (Next_N) then |
3549 | Insert_List_Before_And_Analyze (Next_N, Nodes); | |
3550 | else | |
3551 | Append_List_To (List_Containing (N), Nodes); | |
3552 | end if; | |
3553 | end if; | |
3554 | end if; | |
3555 | ||
3556 | -- Put the local entities back in the enclosing scope, and set the | |
3557 | -- Is_Public flag appropriately. | |
3558 | ||
3559 | Transfer_Entities (S, Enclosing_S); | |
3560 | ||
3561 | -- Mark the enclosing dynamic scope so that the sec stack will be | |
3562 | -- released upon its exit unless this is a function that returns on | |
3563 | -- the sec stack in which case this will be done by the caller. | |
3564 | ||
dbe13a37 | 3565 | if VM_Target = No_VM and then Uses_SS then |
70482933 RK |
3566 | S := Enclosing_Dynamic_Scope (S); |
3567 | ||
3568 | if Ekind (S) = E_Function | |
3569 | and then Requires_Transient_Scope (Etype (S)) | |
3570 | then | |
3571 | null; | |
3572 | else | |
3573 | Set_Uses_Sec_Stack (S); | |
17c5c8a5 | 3574 | Check_Restriction (No_Secondary_Stack, N); |
70482933 RK |
3575 | end if; |
3576 | end if; | |
3577 | end Wrap_Transient_Declaration; | |
3578 | ||
3579 | ------------------------------- | |
3580 | -- Wrap_Transient_Expression -- | |
3581 | ------------------------------- | |
3582 | ||
3583 | -- Insert actions before <Expression>: | |
3584 | ||
3585 | -- (lines marked with <CTRL> are expanded only in presence of Controlled | |
3586 | -- objects needing finalization) | |
3587 | ||
3588 | -- _E : Etyp; | |
3589 | -- declare | |
3590 | -- _M : constant Mark_Id := SS_Mark; | |
3591 | -- Local_Final_List : System.FI.Finalizable_Ptr; <CTRL> | |
3592 | ||
3593 | -- procedure _Clean is | |
3594 | -- begin | |
3595 | -- Abort_Defer; | |
3596 | -- System.FI.Finalize_List (Local_Final_List); <CTRL> | |
3597 | -- SS_Release (M); | |
3598 | -- Abort_Undefer; | |
3599 | -- end _Clean; | |
3600 | ||
3601 | -- begin | |
3602 | -- _E := <Expression>; | |
3603 | -- at end | |
3604 | -- _Clean; | |
3605 | -- end; | |
3606 | ||
3607 | -- then expression is replaced by _E | |
3608 | ||
3609 | procedure Wrap_Transient_Expression (N : Node_Id) is | |
3610 | Loc : constant Source_Ptr := Sloc (N); | |
faf387e1 AC |
3611 | E : constant Entity_Id := Make_Temporary (Loc, 'E', N); |
3612 | Etyp : constant Entity_Id := Etype (N); | |
5568b57c | 3613 | Expr : constant Node_Id := Relocate_Node (N); |
70482933 RK |
3614 | |
3615 | begin | |
3616 | Insert_Actions (N, New_List ( | |
3617 | Make_Object_Declaration (Loc, | |
3618 | Defining_Identifier => E, | |
3619 | Object_Definition => New_Reference_To (Etyp, Loc)), | |
3620 | ||
3621 | Make_Transient_Block (Loc, | |
3622 | Action => | |
3623 | Make_Assignment_Statement (Loc, | |
3624 | Name => New_Reference_To (E, Loc), | |
1c939d81 | 3625 | Expression => Expr)))); |
70482933 RK |
3626 | |
3627 | Rewrite (N, New_Reference_To (E, Loc)); | |
3628 | Analyze_And_Resolve (N, Etyp); | |
3629 | end Wrap_Transient_Expression; | |
3630 | ||
3631 | ------------------------------ | |
3632 | -- Wrap_Transient_Statement -- | |
3633 | ------------------------------ | |
3634 | ||
3635 | -- Transform <Instruction> into | |
3636 | ||
3637 | -- (lines marked with <CTRL> are expanded only in presence of Controlled | |
3638 | -- objects needing finalization) | |
3639 | ||
3640 | -- declare | |
3641 | -- _M : Mark_Id := SS_Mark; | |
3642 | -- Local_Final_List : System.FI.Finalizable_Ptr ; <CTRL> | |
3643 | ||
3644 | -- procedure _Clean is | |
3645 | -- begin | |
3646 | -- Abort_Defer; | |
3647 | -- System.FI.Finalize_List (Local_Final_List); <CTRL> | |
3648 | -- SS_Release (_M); | |
3649 | -- Abort_Undefer; | |
3650 | -- end _Clean; | |
3651 | ||
3652 | -- begin | |
dbe13a37 | 3653 | -- <Instruction>; |
70482933 RK |
3654 | -- at end |
3655 | -- _Clean; | |
3656 | -- end; | |
3657 | ||
3658 | procedure Wrap_Transient_Statement (N : Node_Id) is | |
3659 | Loc : constant Source_Ptr := Sloc (N); | |
3660 | New_Statement : constant Node_Id := Relocate_Node (N); | |
3661 | ||
3662 | begin | |
3663 | Rewrite (N, Make_Transient_Block (Loc, New_Statement)); | |
3664 | ||
3665 | -- With the scope stack back to normal, we can call analyze on the | |
3666 | -- resulting block. At this point, the transient scope is being | |
3667 | -- treated like a perfectly normal scope, so there is nothing | |
3668 | -- special about it. | |
3669 | ||
3670 | -- Note: Wrap_Transient_Statement is called with the node already | |
3671 | -- analyzed (i.e. Analyzed (N) is True). This is important, since | |
3672 | -- otherwise we would get a recursive processing of the node when | |
3673 | -- we do this Analyze call. | |
3674 | ||
3675 | Analyze (N); | |
3676 | end Wrap_Transient_Statement; | |
3677 | ||
3678 | end Exp_Ch7; |