]>
Commit | Line | Data |
---|---|---|
9dfe12ae | 1 | ------------------------------------------------------------------------------ |
ee6ba406 | 2 | -- -- |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ C H 5 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
e9c75a1a | 9 | -- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- |
ee6ba406 | 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- -- | |
80df182a | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
ee6ba406 | 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 -- | |
80df182a | 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. -- | |
ee6ba406 | 20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
e78e8c8e | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
ee6ba406 | 23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
a053db0d | 26 | with Aspects; use Aspects; |
ee6ba406 | 27 | with Atree; use Atree; |
28 | with Checks; use Checks; | |
0326143c | 29 | with Debug; use Debug; |
ee6ba406 | 30 | with Einfo; use Einfo; |
05987af3 | 31 | with Elists; use Elists; |
4e104ca3 | 32 | with Errout; use Errout; |
ee6ba406 | 33 | with Exp_Aggr; use Exp_Aggr; |
0326143c | 34 | with Exp_Ch6; use Exp_Ch6; |
ee6ba406 | 35 | with Exp_Ch7; use Exp_Ch7; |
36 | with Exp_Ch11; use Exp_Ch11; | |
37 | with Exp_Dbug; use Exp_Dbug; | |
38 | with Exp_Pakd; use Exp_Pakd; | |
bd550baf | 39 | with Exp_Tss; use Exp_Tss; |
ee6ba406 | 40 | with Exp_Util; use Exp_Util; |
32d2c8a5 | 41 | with Inline; use Inline; |
0524b5dd | 42 | with Namet; use Namet; |
ee6ba406 | 43 | with Nlists; use Nlists; |
44 | with Nmake; use Nmake; | |
45 | with Opt; use Opt; | |
46 | with Restrict; use Restrict; | |
1e16c51c | 47 | with Rident; use Rident; |
ee6ba406 | 48 | with Rtsfind; use Rtsfind; |
49 | with Sinfo; use Sinfo; | |
50 | with Sem; use Sem; | |
d60c9ff7 | 51 | with Sem_Aux; use Sem_Aux; |
00f91aef | 52 | with Sem_Ch3; use Sem_Ch3; |
ee6ba406 | 53 | with Sem_Ch8; use Sem_Ch8; |
54 | with Sem_Ch13; use Sem_Ch13; | |
55 | with Sem_Eval; use Sem_Eval; | |
56 | with Sem_Res; use Sem_Res; | |
57 | with Sem_Util; use Sem_Util; | |
58 | with Snames; use Snames; | |
59 | with Stand; use Stand; | |
5c61a0ff | 60 | with Stringt; use Stringt; |
ee6ba406 | 61 | with Tbuild; use Tbuild; |
05987af3 | 62 | with Uintp; use Uintp; |
ee6ba406 | 63 | with Validsw; use Validsw; |
64 | ||
65 | package body Exp_Ch5 is | |
66 | ||
cdf1647b | 67 | procedure Build_Formal_Container_Iteration |
68 | (N : Node_Id; | |
69 | Container : Entity_Id; | |
70 | Cursor : Entity_Id; | |
71 | Init : out Node_Id; | |
72 | Advance : out Node_Id; | |
73 | New_Loop : out Node_Id); | |
74 | -- Utility to create declarations and loop statement for both forms | |
75 | -- of formal container iterators. | |
76 | ||
69591398 | 77 | function Convert_To_Iterable_Type |
88d1247a | 78 | (Container : Entity_Id; |
79 | Loc : Source_Ptr) return Node_Id; | |
80 | -- Returns New_Occurrence_Of (Container), possibly converted to an ancestor | |
81 | -- type, if the type of Container inherited the Iterable aspect from that | |
82 | -- ancestor. | |
69591398 | 83 | |
ee6ba406 | 84 | function Change_Of_Representation (N : Node_Id) return Boolean; |
7748ccb2 | 85 | -- Determine if the right-hand side of assignment N is a type conversion |
40d4441d | 86 | -- which requires a change of representation. Called only for the array |
87 | -- and record cases. | |
ee6ba406 | 88 | |
89 | procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id); | |
90 | -- N is an assignment which assigns an array value. This routine process | |
91 | -- the various special cases and checks required for such assignments, | |
7748ccb2 | 92 | -- including change of representation. Rhs is normally simply the right- |
93 | -- hand side of the assignment, except that if the right-hand side is a | |
40d4441d | 94 | -- type conversion or a qualified expression, then the RHS is the actual |
95 | -- expression inside any such type conversions or qualifications. | |
ee6ba406 | 96 | |
97 | function Expand_Assign_Array_Loop | |
98 | (N : Node_Id; | |
99 | Larray : Entity_Id; | |
100 | Rarray : Entity_Id; | |
101 | L_Type : Entity_Id; | |
102 | R_Type : Entity_Id; | |
103 | Ndim : Pos; | |
5c61a0ff | 104 | Rev : Boolean) return Node_Id; |
ee6ba406 | 105 | -- N is an assignment statement which assigns an array value. This routine |
106 | -- expands the assignment into a loop (or nested loops for the case of a | |
107 | -- multi-dimensional array) to do the assignment component by component. | |
7748ccb2 | 108 | -- Larray and Rarray are the entities of the actual arrays on the left-hand |
109 | -- and right-hand sides. L_Type and R_Type are the types of these arrays | |
110 | -- (which may not be the same, due to either sliding, or to a change of | |
111 | -- representation case). Ndim is the number of dimensions and the parameter | |
112 | -- Rev indicates if the loops run normally (Rev = False), or reversed | |
113 | -- (Rev = True). The value returned is the constructed loop statement. | |
114 | -- Auxiliary declarations are inserted before node N using the standard | |
115 | -- Insert_Actions mechanism. | |
ee6ba406 | 116 | |
117 | procedure Expand_Assign_Record (N : Node_Id); | |
e14a3829 | 118 | -- N is an assignment of an untagged record value. This routine handles |
b3fb26fd | 119 | -- the case where the assignment must be made component by component, |
120 | -- either because the target is not byte aligned, or there is a change | |
d2b860b4 | 121 | -- of representation, or when we have a tagged type with a representation |
122 | -- clause (this last case is required because holes in the tagged type | |
123 | -- might be filled with components from child types). | |
b3fb26fd | 124 | |
0d105023 | 125 | procedure Expand_Assign_With_Target_Names (N : Node_Id); |
126 | -- (AI12-0125): N is an assignment statement whose RHS contains occurrences | |
127 | -- of @ that designate the value of the LHS of the assignment. If the LHS | |
128 | -- is side-effect free the target names can be replaced with a copy of the | |
129 | -- LHS; otherwise the semantics of the assignment is described in terms of | |
130 | -- a procedure with an in-out parameter, and expanded as such. | |
131 | ||
cdf1647b | 132 | procedure Expand_Formal_Container_Loop (N : Node_Id); |
bde03454 | 133 | -- Use the primitives specified in an Iterable aspect to expand a loop |
134 | -- over a so-called formal container, primarily for SPARK usage. | |
b3f8228a | 135 | |
cdf1647b | 136 | procedure Expand_Formal_Container_Element_Loop (N : Node_Id); |
137 | -- Same, for an iterator of the form " For E of C". In this case the | |
138 | -- iterator provides the name of the element, and the cursor is generated | |
139 | -- internally. | |
140 | ||
f37e6e70 | 141 | procedure Expand_Iterator_Loop (N : Node_Id); |
75ef9625 | 142 | -- Expand loop over arrays and containers that uses the form "for X of C" |
143 | -- with an optional subtype mark, or "for Y in C". | |
f37e6e70 | 144 | |
b7974341 | 145 | procedure Expand_Iterator_Loop_Over_Container |
146 | (N : Node_Id; | |
147 | Isc : Node_Id; | |
148 | I_Spec : Node_Id; | |
149 | Container : Node_Id; | |
150 | Container_Typ : Entity_Id); | |
151 | -- Expand loop over containers that uses the form "for X of C" with an | |
152 | -- optional subtype mark, or "for Y in C". Isc is the iteration scheme. | |
153 | -- I_Spec is the iterator specification and Container is either the | |
154 | -- Container (for OF) or the iterator (for IN). | |
155 | ||
55e8372b | 156 | procedure Expand_Predicated_Loop (N : Node_Id); |
157 | -- Expand for loop over predicated subtype | |
158 | ||
ee6ba406 | 159 | function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; |
d2b860b4 | 160 | -- Generate the necessary code for controlled and tagged assignment, that |
161 | -- is to say, finalization of the target before, adjustment of the target | |
162 | -- after and save and restore of the tag and finalization pointers which | |
163 | -- are not 'part of the value' and must not be changed upon assignment. N | |
164 | -- is the original Assignment node. | |
ee6ba406 | 165 | |
cdf1647b | 166 | -------------------------------------- |
bacd5059 | 167 | -- Build_Formal_Container_Iteration -- |
cdf1647b | 168 | -------------------------------------- |
169 | ||
170 | procedure Build_Formal_Container_Iteration | |
171 | (N : Node_Id; | |
172 | Container : Entity_Id; | |
173 | Cursor : Entity_Id; | |
174 | Init : out Node_Id; | |
175 | Advance : out Node_Id; | |
176 | New_Loop : out Node_Id) | |
177 | is | |
e0e76328 | 178 | Loc : constant Source_Ptr := Sloc (N); |
179 | Stats : constant List_Id := Statements (N); | |
180 | Typ : constant Entity_Id := Base_Type (Etype (Container)); | |
181 | ||
182 | Has_Element_Op : constant Entity_Id := | |
183 | Get_Iterable_Type_Primitive (Typ, Name_Has_Element); | |
cf0f46aa | 184 | |
185 | First_Op : Entity_Id; | |
186 | Next_Op : Entity_Id; | |
630b6d55 | 187 | |
cdf1647b | 188 | begin |
cf0f46aa | 189 | -- Use the proper set of primitives depending on the direction of |
190 | -- iteration. The legality of a reverse iteration has been checked | |
191 | -- during analysis. | |
192 | ||
193 | if Reverse_Present (Iterator_Specification (Iteration_Scheme (N))) then | |
194 | First_Op := Get_Iterable_Type_Primitive (Typ, Name_Last); | |
195 | Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Previous); | |
196 | ||
197 | else | |
198 | First_Op := Get_Iterable_Type_Primitive (Typ, Name_First); | |
199 | Next_Op := Get_Iterable_Type_Primitive (Typ, Name_Next); | |
cf0f46aa | 200 | end if; |
201 | ||
cdf1647b | 202 | -- Declaration for Cursor |
203 | ||
204 | Init := | |
630b6d55 | 205 | Make_Object_Declaration (Loc, |
206 | Defining_Identifier => Cursor, | |
207 | Object_Definition => New_Occurrence_Of (Etype (First_Op), Loc), | |
208 | Expression => | |
209 | Make_Function_Call (Loc, | |
210 | Name => New_Occurrence_Of (First_Op, Loc), | |
211 | Parameter_Associations => New_List ( | |
69591398 | 212 | Convert_To_Iterable_Type (Container, Loc)))); |
cdf1647b | 213 | |
cf0f46aa | 214 | -- Statement that advances (in the right direction) cursor in loop |
cdf1647b | 215 | |
216 | Advance := | |
217 | Make_Assignment_Statement (Loc, | |
630b6d55 | 218 | Name => New_Occurrence_Of (Cursor, Loc), |
cdf1647b | 219 | Expression => |
220 | Make_Function_Call (Loc, | |
630b6d55 | 221 | Name => New_Occurrence_Of (Next_Op, Loc), |
222 | Parameter_Associations => New_List ( | |
69591398 | 223 | Convert_To_Iterable_Type (Container, Loc), |
630b6d55 | 224 | New_Occurrence_Of (Cursor, Loc)))); |
cdf1647b | 225 | |
226 | -- Iterator is rewritten as a while_loop | |
227 | ||
228 | New_Loop := | |
229 | Make_Loop_Statement (Loc, | |
230 | Iteration_Scheme => | |
231 | Make_Iteration_Scheme (Loc, | |
232 | Condition => | |
233 | Make_Function_Call (Loc, | |
69591398 | 234 | Name => New_Occurrence_Of (Has_Element_Op, Loc), |
630b6d55 | 235 | Parameter_Associations => New_List ( |
69591398 | 236 | Convert_To_Iterable_Type (Container, Loc), |
630b6d55 | 237 | New_Occurrence_Of (Cursor, Loc)))), |
69591398 | 238 | Statements => Stats, |
239 | End_Label => Empty); | |
7d11fe29 | 240 | |
f2f4c3c2 | 241 | -- If the contruct has a specified loop name, preserve it in the new |
242 | -- loop, for possible use in exit statements. | |
7d11fe29 | 243 | |
244 | if Present (Identifier (N)) | |
245 | and then Comes_From_Source (Identifier (N)) | |
246 | then | |
247 | Set_Identifier (New_Loop, Identifier (N)); | |
248 | end if; | |
cdf1647b | 249 | end Build_Formal_Container_Iteration; |
250 | ||
ee6ba406 | 251 | ------------------------------ |
252 | -- Change_Of_Representation -- | |
253 | ------------------------------ | |
254 | ||
255 | function Change_Of_Representation (N : Node_Id) return Boolean is | |
256 | Rhs : constant Node_Id := Expression (N); | |
ee6ba406 | 257 | begin |
258 | return | |
259 | Nkind (Rhs) = N_Type_Conversion | |
260 | and then | |
261 | not Same_Representation (Etype (Rhs), Etype (Expression (Rhs))); | |
262 | end Change_Of_Representation; | |
263 | ||
69591398 | 264 | ------------------------------ |
265 | -- Convert_To_Iterable_Type -- | |
266 | ------------------------------ | |
267 | ||
268 | function Convert_To_Iterable_Type | |
88d1247a | 269 | (Container : Entity_Id; |
270 | Loc : Source_Ptr) return Node_Id | |
69591398 | 271 | is |
88d1247a | 272 | Typ : constant Entity_Id := Base_Type (Etype (Container)); |
273 | Aspect : constant Node_Id := Find_Aspect (Typ, Aspect_Iterable); | |
274 | Result : Node_Id; | |
275 | ||
69591398 | 276 | begin |
88d1247a | 277 | Result := New_Occurrence_Of (Container, Loc); |
278 | ||
69591398 | 279 | if Entity (Aspect) /= Typ then |
88d1247a | 280 | Result := |
281 | Make_Type_Conversion (Loc, | |
282 | Subtype_Mark => New_Occurrence_Of (Entity (Aspect), Loc), | |
283 | Expression => Result); | |
69591398 | 284 | end if; |
285 | ||
286 | return Result; | |
287 | end Convert_To_Iterable_Type; | |
288 | ||
ee6ba406 | 289 | ------------------------- |
290 | -- Expand_Assign_Array -- | |
291 | ------------------------- | |
292 | ||
293 | -- There are two issues here. First, do we let Gigi do a block move, or | |
294 | -- do we expand out into a loop? Second, we need to set the two flags | |
295 | -- Forwards_OK and Backwards_OK which show whether the block move (or | |
296 | -- corresponding loops) can be legitimately done in a forwards (low to | |
297 | -- high) or backwards (high to low) manner. | |
298 | ||
299 | procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is | |
300 | Loc : constant Source_Ptr := Sloc (N); | |
301 | ||
302 | Lhs : constant Node_Id := Name (N); | |
303 | ||
304 | Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs); | |
305 | Act_Rhs : Node_Id := Get_Referenced_Object (Rhs); | |
306 | ||
307 | L_Type : constant Entity_Id := | |
308 | Underlying_Type (Get_Actual_Subtype (Act_Lhs)); | |
309 | R_Type : Entity_Id := | |
310 | Underlying_Type (Get_Actual_Subtype (Act_Rhs)); | |
311 | ||
312 | L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice; | |
313 | R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice; | |
314 | ||
315 | Crep : constant Boolean := Change_Of_Representation (N); | |
316 | ||
317 | Larray : Node_Id; | |
318 | Rarray : Node_Id; | |
319 | ||
320 | Ndim : constant Pos := Number_Dimensions (L_Type); | |
321 | ||
322 | Loop_Required : Boolean := False; | |
323 | -- This switch is set to True if the array move must be done using | |
324 | -- an explicit front end generated loop. | |
325 | ||
a2feb922 | 326 | procedure Apply_Dereference (Arg : Node_Id); |
bd550baf | 327 | -- If the argument is an access to an array, and the assignment is |
328 | -- converted into a procedure call, apply explicit dereference. | |
329 | ||
ee6ba406 | 330 | function Has_Address_Clause (Exp : Node_Id) return Boolean; |
331 | -- Test if Exp is a reference to an array whose declaration has | |
332 | -- an address clause, or it is a slice of such an array. | |
333 | ||
334 | function Is_Formal_Array (Exp : Node_Id) return Boolean; | |
335 | -- Test if Exp is a reference to an array which is either a formal | |
336 | -- parameter or a slice of a formal parameter. These are the cases | |
337 | -- where hidden aliasing can occur. | |
338 | ||
339 | function Is_Non_Local_Array (Exp : Node_Id) return Boolean; | |
340 | -- Determine if Exp is a reference to an array variable which is other | |
ef167e07 | 341 | -- than an object defined in the current scope, or a component or a |
342 | -- slice of such an object. Such objects can be aliased to parameters | |
343 | -- (unlike local array references). | |
ee6ba406 | 344 | |
bd550baf | 345 | ----------------------- |
346 | -- Apply_Dereference -- | |
347 | ----------------------- | |
348 | ||
a2feb922 | 349 | procedure Apply_Dereference (Arg : Node_Id) is |
bd550baf | 350 | Typ : constant Entity_Id := Etype (Arg); |
351 | begin | |
352 | if Is_Access_Type (Typ) then | |
353 | Rewrite (Arg, Make_Explicit_Dereference (Loc, | |
354 | Prefix => Relocate_Node (Arg))); | |
355 | Analyze_And_Resolve (Arg, Designated_Type (Typ)); | |
356 | end if; | |
357 | end Apply_Dereference; | |
358 | ||
ee6ba406 | 359 | ------------------------ |
360 | -- Has_Address_Clause -- | |
361 | ------------------------ | |
362 | ||
363 | function Has_Address_Clause (Exp : Node_Id) return Boolean is | |
364 | begin | |
365 | return | |
366 | (Is_Entity_Name (Exp) and then | |
367 | Present (Address_Clause (Entity (Exp)))) | |
368 | or else | |
369 | (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp))); | |
370 | end Has_Address_Clause; | |
371 | ||
372 | --------------------- | |
373 | -- Is_Formal_Array -- | |
374 | --------------------- | |
375 | ||
376 | function Is_Formal_Array (Exp : Node_Id) return Boolean is | |
377 | begin | |
378 | return | |
379 | (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp))) | |
380 | or else | |
381 | (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp))); | |
382 | end Is_Formal_Array; | |
383 | ||
384 | ------------------------ | |
385 | -- Is_Non_Local_Array -- | |
386 | ------------------------ | |
387 | ||
388 | function Is_Non_Local_Array (Exp : Node_Id) return Boolean is | |
389 | begin | |
ef167e07 | 390 | case Nkind (Exp) is |
99378362 | 391 | when N_Indexed_Component |
392 | | N_Selected_Component | |
393 | | N_Slice | |
394 | => | |
ef167e07 | 395 | return Is_Non_Local_Array (Prefix (Exp)); |
71d4161f | 396 | |
ef167e07 | 397 | when others => |
398 | return | |
71d4161f | 399 | not (Is_Entity_Name (Exp) |
400 | and then Scope (Entity (Exp)) = Current_Scope); | |
ef167e07 | 401 | end case; |
ee6ba406 | 402 | end Is_Non_Local_Array; |
403 | ||
9dfe12ae | 404 | -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays |
ee6ba406 | 405 | |
406 | Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs); | |
407 | Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs); | |
408 | ||
409 | Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs); | |
410 | Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs); | |
411 | ||
412 | -- Start of processing for Expand_Assign_Array | |
413 | ||
414 | begin | |
a2feb922 | 415 | -- Deal with length check. Note that the length check is done with |
7748ccb2 | 416 | -- respect to the right-hand side as given, not a possible underlying |
ee6ba406 | 417 | -- renamed object, since this would generate incorrect extra checks. |
418 | ||
419 | Apply_Length_Check (Rhs, L_Type); | |
420 | ||
a2feb922 | 421 | -- We start by assuming that the move can be done in either direction, |
422 | -- i.e. that the two sides are completely disjoint. | |
ee6ba406 | 423 | |
424 | Set_Forwards_OK (N, True); | |
425 | Set_Backwards_OK (N, True); | |
426 | ||
0524b5dd | 427 | -- Normally it is only the slice case that can lead to overlap, and |
428 | -- explicit checks for slices are made below. But there is one case | |
a2feb922 | 429 | -- where the slice can be implicit and invisible to us: when we have a |
430 | -- one dimensional array, and either both operands are parameters, or | |
431 | -- one is a parameter (which can be a slice passed by reference) and the | |
432 | -- other is a non-local variable. In this case the parameter could be a | |
433 | -- slice that overlaps with the other operand. | |
434 | ||
0524b5dd | 435 | -- However, if the array subtype is a constrained first subtype in the |
436 | -- parameter case, then we don't have to worry about overlap, since | |
437 | -- slice assignments aren't possible (other than for a slice denoting | |
438 | -- the whole array). | |
439 | ||
440 | -- Note: No overlap is possible if there is a change of representation, | |
441 | -- so we can exclude this case. | |
ee6ba406 | 442 | |
ee6ba406 | 443 | if Ndim = 1 |
444 | and then not Crep | |
445 | and then | |
446 | ((Lhs_Formal and Rhs_Formal) | |
447 | or else | |
448 | (Lhs_Formal and Rhs_Non_Local_Var) | |
449 | or else | |
450 | (Rhs_Formal and Lhs_Non_Local_Var)) | |
9dfe12ae | 451 | and then |
452 | (not Is_Constrained (Etype (Lhs)) | |
453 | or else not Is_First_Subtype (Etype (Lhs))) | |
ee6ba406 | 454 | then |
455 | Set_Forwards_OK (N, False); | |
456 | Set_Backwards_OK (N, False); | |
457 | ||
0524b5dd | 458 | -- Note: the bit-packed case is not worrisome here, since if we have |
459 | -- a slice passed as a parameter, it is always aligned on a byte | |
460 | -- boundary, and if there are no explicit slices, the assignment | |
461 | -- can be performed directly. | |
ee6ba406 | 462 | end if; |
463 | ||
59db1732 | 464 | -- If either operand has an address clause clear Backwards_OK and |
e10874de | 465 | -- Forwards_OK, since we cannot tell if the operands overlap. We |
466 | -- exclude this treatment when Rhs is an aggregate, since we know | |
467 | -- that overlap can't occur. | |
59db1732 | 468 | |
e10874de | 469 | if (Has_Address_Clause (Lhs) and then Nkind (Rhs) /= N_Aggregate) |
470 | or else Has_Address_Clause (Rhs) | |
471 | then | |
59db1732 | 472 | Set_Forwards_OK (N, False); |
473 | Set_Backwards_OK (N, False); | |
474 | end if; | |
475 | ||
0524b5dd | 476 | -- We certainly must use a loop for change of representation and also |
7748ccb2 | 477 | -- we use the operand of the conversion on the right-hand side as the |
478 | -- effective right-hand side (the component types must match in this | |
0524b5dd | 479 | -- situation). |
ee6ba406 | 480 | |
481 | if Crep then | |
482 | Act_Rhs := Get_Referenced_Object (Rhs); | |
483 | R_Type := Get_Actual_Subtype (Act_Rhs); | |
484 | Loop_Required := True; | |
485 | ||
05e5286d | 486 | -- We require a loop if the left side is possibly bit unaligned |
487 | ||
cf6d853e | 488 | elsif Possible_Bit_Aligned_Component (Lhs) |
05e5286d | 489 | or else |
cf6d853e | 490 | Possible_Bit_Aligned_Component (Rhs) |
05e5286d | 491 | then |
492 | Loop_Required := True; | |
493 | ||
a2feb922 | 494 | -- Arrays with controlled components are expanded into a loop to force |
495 | -- calls to Adjust at the component level. | |
ee6ba406 | 496 | |
497 | elsif Has_Controlled_Component (L_Type) then | |
498 | Loop_Required := True; | |
499 | ||
2fe893b9 | 500 | -- If object is atomic/VFA, we cannot tolerate a loop |
f84d3d59 | 501 | |
2fe893b9 | 502 | elsif Is_Atomic_Or_VFA_Object (Act_Lhs) |
f84d3d59 | 503 | or else |
2fe893b9 | 504 | Is_Atomic_Or_VFA_Object (Act_Rhs) |
f84d3d59 | 505 | then |
506 | return; | |
507 | ||
508 | -- Loop is required if we have atomic components since we have to | |
509 | -- be sure to do any accesses on an element by element basis. | |
510 | ||
511 | elsif Has_Atomic_Components (L_Type) | |
512 | or else Has_Atomic_Components (R_Type) | |
2fe893b9 | 513 | or else Is_Atomic_Or_VFA (Component_Type (L_Type)) |
514 | or else Is_Atomic_Or_VFA (Component_Type (R_Type)) | |
f84d3d59 | 515 | then |
516 | Loop_Required := True; | |
517 | ||
f15731c4 | 518 | -- Case where no slice is involved |
ee6ba406 | 519 | |
520 | elsif not L_Slice and not R_Slice then | |
521 | ||
0524b5dd | 522 | -- The following code deals with the case of unconstrained bit packed |
523 | -- arrays. The problem is that the template for such arrays contains | |
524 | -- the bounds of the actual source level array, but the copy of an | |
525 | -- entire array requires the bounds of the underlying array. It would | |
526 | -- be nice if the back end could take care of this, but right now it | |
527 | -- does not know how, so if we have such a type, then we expand out | |
528 | -- into a loop, which is inefficient but works correctly. If we don't | |
529 | -- do this, we get the wrong length computed for the array to be | |
530 | -- moved. The two cases we need to worry about are: | |
f15731c4 | 531 | |
eae1d4d1 | 532 | -- Explicit dereference of an unconstrained packed array type as in |
533 | -- the following example: | |
ee6ba406 | 534 | |
535 | -- procedure C52 is | |
536 | -- type BITS is array(INTEGER range <>) of BOOLEAN; | |
537 | -- pragma PACK(BITS); | |
538 | -- type A is access BITS; | |
539 | -- P1,P2 : A; | |
540 | -- begin | |
541 | -- P1 := new BITS (1 .. 65_535); | |
542 | -- P2 := new BITS (1 .. 65_535); | |
543 | -- P2.ALL := P1.ALL; | |
544 | -- end C52; | |
545 | ||
0524b5dd | 546 | -- A formal parameter reference with an unconstrained bit array type |
547 | -- is the other case we need to worry about (here we assume the same | |
548 | -- BITS type declared above): | |
f15731c4 | 549 | |
0326143c | 550 | -- procedure Write_All (File : out BITS; Contents : BITS); |
f15731c4 | 551 | -- begin |
552 | -- File.Storage := Contents; | |
553 | -- end Write_All; | |
554 | ||
46ed552e | 555 | -- We expand to a loop in either of these two cases |
f15731c4 | 556 | |
557 | -- Question for future thought. Another potentially more efficient | |
558 | -- approach would be to create the actual subtype, and then do an | |
559 | -- unchecked conversion to this actual subtype ??? | |
ee6ba406 | 560 | |
f15731c4 | 561 | Check_Unconstrained_Bit_Packed_Array : declare |
ee6ba406 | 562 | |
f15731c4 | 563 | function Is_UBPA_Reference (Opnd : Node_Id) return Boolean; |
0524b5dd | 564 | -- Function to perform required test for the first case, above |
a2feb922 | 565 | -- (dereference of an unconstrained bit packed array). |
f15731c4 | 566 | |
567 | ----------------------- | |
568 | -- Is_UBPA_Reference -- | |
569 | ----------------------- | |
570 | ||
571 | function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is | |
572 | Typ : constant Entity_Id := Underlying_Type (Etype (Opnd)); | |
ee6ba406 | 573 | P_Type : Entity_Id; |
574 | Des_Type : Entity_Id; | |
575 | ||
576 | begin | |
a88a5773 | 577 | if Present (Packed_Array_Impl_Type (Typ)) |
578 | and then Is_Array_Type (Packed_Array_Impl_Type (Typ)) | |
579 | and then not Is_Constrained (Packed_Array_Impl_Type (Typ)) | |
f15731c4 | 580 | then |
581 | return True; | |
582 | ||
583 | elsif Nkind (Opnd) = N_Explicit_Dereference then | |
584 | P_Type := Underlying_Type (Etype (Prefix (Opnd))); | |
ee6ba406 | 585 | |
586 | if not Is_Access_Type (P_Type) then | |
587 | return False; | |
588 | ||
589 | else | |
590 | Des_Type := Designated_Type (P_Type); | |
591 | return | |
592 | Is_Bit_Packed_Array (Des_Type) | |
593 | and then not Is_Constrained (Des_Type); | |
594 | end if; | |
f15731c4 | 595 | |
596 | else | |
597 | return False; | |
ee6ba406 | 598 | end if; |
f15731c4 | 599 | end Is_UBPA_Reference; |
ee6ba406 | 600 | |
f15731c4 | 601 | -- Start of processing for Check_Unconstrained_Bit_Packed_Array |
ee6ba406 | 602 | |
603 | begin | |
f15731c4 | 604 | if Is_UBPA_Reference (Lhs) |
ee6ba406 | 605 | or else |
f15731c4 | 606 | Is_UBPA_Reference (Rhs) |
ee6ba406 | 607 | then |
608 | Loop_Required := True; | |
609 | ||
0524b5dd | 610 | -- Here if we do not have the case of a reference to a bit packed |
611 | -- unconstrained array case. In this case gigi can most certainly | |
612 | -- handle the assignment if a forwards move is allowed. | |
f15731c4 | 613 | |
614 | -- (could it handle the backwards case also???) | |
ee6ba406 | 615 | |
616 | elsif Forwards_OK (N) then | |
617 | return; | |
618 | end if; | |
f15731c4 | 619 | end Check_Unconstrained_Bit_Packed_Array; |
ee6ba406 | 620 | |
4660e715 | 621 | -- The back end can always handle the assignment if the right side is a |
622 | -- string literal (note that overlap is definitely impossible in this | |
623 | -- case). If the type is packed, a string literal is always converted | |
a2feb922 | 624 | -- into an aggregate, except in the case of a null slice, for which no |
4660e715 | 625 | -- aggregate can be written. In that case, rewrite the assignment as a |
626 | -- null statement, a length check has already been emitted to verify | |
627 | -- that the range of the left-hand side is empty. | |
ee6ba406 | 628 | |
a2feb922 | 629 | -- Note that this code is not executed if we have an assignment of a |
0524b5dd | 630 | -- string literal to a non-bit aligned component of a record, a case |
a2feb922 | 631 | -- which cannot be handled by the backend. |
5c61a0ff | 632 | |
ee6ba406 | 633 | elsif Nkind (Rhs) = N_String_Literal then |
5c61a0ff | 634 | if String_Length (Strval (Rhs)) = 0 |
9dfe12ae | 635 | and then Is_Bit_Packed_Array (L_Type) |
636 | then | |
637 | Rewrite (N, Make_Null_Statement (Loc)); | |
638 | Analyze (N); | |
639 | end if; | |
640 | ||
ee6ba406 | 641 | return; |
642 | ||
0524b5dd | 643 | -- If either operand is bit packed, then we need a loop, since we can't |
644 | -- be sure that the slice is byte aligned. Similarly, if either operand | |
645 | -- is a possibly unaligned slice, then we need a loop (since the back | |
646 | -- end cannot handle unaligned slices). | |
ee6ba406 | 647 | |
648 | elsif Is_Bit_Packed_Array (L_Type) | |
649 | or else Is_Bit_Packed_Array (R_Type) | |
aab8de0a | 650 | or else Is_Possibly_Unaligned_Slice (Lhs) |
651 | or else Is_Possibly_Unaligned_Slice (Rhs) | |
ee6ba406 | 652 | then |
653 | Loop_Required := True; | |
654 | ||
0524b5dd | 655 | -- If we are not bit-packed, and we have only one slice, then no overlap |
656 | -- is possible except in the parameter case, so we can let the back end | |
657 | -- handle things. | |
ee6ba406 | 658 | |
659 | elsif not (L_Slice and R_Slice) then | |
660 | if Forwards_OK (N) then | |
661 | return; | |
662 | end if; | |
663 | end if; | |
664 | ||
0524b5dd | 665 | -- If the right-hand side is a string literal, introduce a temporary for |
666 | -- it, for use in the generated loop that will follow. | |
28ed91d4 | 667 | |
668 | if Nkind (Rhs) = N_String_Literal then | |
669 | declare | |
e0394eca | 670 | Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs); |
28ed91d4 | 671 | Decl : Node_Id; |
672 | ||
673 | begin | |
674 | Decl := | |
675 | Make_Object_Declaration (Loc, | |
676 | Defining_Identifier => Temp, | |
677 | Object_Definition => New_Occurrence_Of (L_Type, Loc), | |
678 | Expression => Relocate_Node (Rhs)); | |
679 | ||
680 | Insert_Action (N, Decl); | |
681 | Rewrite (Rhs, New_Occurrence_Of (Temp, Loc)); | |
682 | R_Type := Etype (Temp); | |
683 | end; | |
684 | end if; | |
685 | ||
686 | -- Come here to complete the analysis | |
ee6ba406 | 687 | |
688 | -- Loop_Required: Set to True if we know that a loop is required | |
689 | -- regardless of overlap considerations. | |
690 | ||
691 | -- Forwards_OK: Set to False if we already know that a forwards | |
692 | -- move is not safe, else set to True. | |
693 | ||
694 | -- Backwards_OK: Set to False if we already know that a backwards | |
695 | -- move is not safe, else set to True | |
696 | ||
0524b5dd | 697 | -- Our task at this stage is to complete the overlap analysis, which can |
698 | -- result in possibly setting Forwards_OK or Backwards_OK to False, and | |
699 | -- then generating the final code, either by deciding that it is OK | |
700 | -- after all to let Gigi handle it, or by generating appropriate code | |
701 | -- in the front end. | |
ee6ba406 | 702 | |
703 | declare | |
704 | L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type)); | |
705 | R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type)); | |
706 | ||
707 | Left_Lo : constant Node_Id := Type_Low_Bound (L_Index_Typ); | |
708 | Left_Hi : constant Node_Id := Type_High_Bound (L_Index_Typ); | |
709 | Right_Lo : constant Node_Id := Type_Low_Bound (R_Index_Typ); | |
710 | Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ); | |
711 | ||
712 | Act_L_Array : Node_Id; | |
713 | Act_R_Array : Node_Id; | |
714 | ||
715 | Cleft_Lo : Node_Id; | |
716 | Cright_Lo : Node_Id; | |
717 | Condition : Node_Id; | |
718 | ||
719 | Cresult : Compare_Result; | |
720 | ||
721 | begin | |
722 | -- Get the expressions for the arrays. If we are dealing with a | |
723 | -- private type, then convert to the underlying type. We can do | |
0524b5dd | 724 | -- direct assignments to an array that is a private type, but we |
725 | -- cannot assign to elements of the array without this extra | |
ee6ba406 | 726 | -- unchecked conversion. |
727 | ||
174d1afa | 728 | -- Note: We propagate Parent to the conversion nodes to generate |
729 | -- a well-formed subtree. | |
a35b881d | 730 | |
ee6ba406 | 731 | if Nkind (Act_Lhs) = N_Slice then |
732 | Larray := Prefix (Act_Lhs); | |
733 | else | |
734 | Larray := Act_Lhs; | |
735 | ||
736 | if Is_Private_Type (Etype (Larray)) then | |
a35b881d | 737 | declare |
738 | Par : constant Node_Id := Parent (Larray); | |
739 | begin | |
740 | Larray := | |
741 | Unchecked_Convert_To | |
742 | (Underlying_Type (Etype (Larray)), Larray); | |
743 | Set_Parent (Larray, Par); | |
744 | end; | |
ee6ba406 | 745 | end if; |
746 | end if; | |
747 | ||
748 | if Nkind (Act_Rhs) = N_Slice then | |
749 | Rarray := Prefix (Act_Rhs); | |
750 | else | |
751 | Rarray := Act_Rhs; | |
752 | ||
753 | if Is_Private_Type (Etype (Rarray)) then | |
a35b881d | 754 | declare |
755 | Par : constant Node_Id := Parent (Rarray); | |
756 | begin | |
757 | Rarray := | |
758 | Unchecked_Convert_To | |
759 | (Underlying_Type (Etype (Rarray)), Rarray); | |
760 | Set_Parent (Rarray, Par); | |
761 | end; | |
ee6ba406 | 762 | end if; |
763 | end if; | |
764 | ||
0524b5dd | 765 | -- If both sides are slices, we must figure out whether it is safe |
a2feb922 | 766 | -- to do the move in one direction or the other. It is always safe |
767 | -- if there is a change of representation since obviously two arrays | |
0524b5dd | 768 | -- with different representations cannot possibly overlap. |
ee6ba406 | 769 | |
770 | if (not Crep) and L_Slice and R_Slice then | |
771 | Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs)); | |
772 | Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs)); | |
773 | ||
7748ccb2 | 774 | -- If both left- and right-hand arrays are entity names, and refer |
0524b5dd | 775 | -- to different entities, then we know that the move is safe (the |
776 | -- two storage areas are completely disjoint). | |
ee6ba406 | 777 | |
778 | if Is_Entity_Name (Act_L_Array) | |
779 | and then Is_Entity_Name (Act_R_Array) | |
780 | and then Entity (Act_L_Array) /= Entity (Act_R_Array) | |
781 | then | |
782 | null; | |
783 | ||
0524b5dd | 784 | -- Otherwise, we assume the worst, which is that the two arrays |
785 | -- are the same array. There is no need to check if we know that | |
786 | -- is the case, because if we don't know it, we still have to | |
39a0c1d3 | 787 | -- assume it. |
ee6ba406 | 788 | |
0524b5dd | 789 | -- Generally if the same array is involved, then we have an |
790 | -- overlapping case. We will have to really assume the worst (i.e. | |
791 | -- set neither of the OK flags) unless we can determine the lower | |
792 | -- or upper bounds at compile time and compare them. | |
ee6ba406 | 793 | |
794 | else | |
e254d721 | 795 | Cresult := |
796 | Compile_Time_Compare | |
797 | (Left_Lo, Right_Lo, Assume_Valid => True); | |
ee6ba406 | 798 | |
799 | if Cresult = Unknown then | |
e254d721 | 800 | Cresult := |
801 | Compile_Time_Compare | |
802 | (Left_Hi, Right_Hi, Assume_Valid => True); | |
ee6ba406 | 803 | end if; |
804 | ||
805 | case Cresult is | |
99378362 | 806 | when EQ | LE | LT => |
807 | Set_Backwards_OK (N, False); | |
808 | ||
809 | when GE | GT => | |
810 | Set_Forwards_OK (N, False); | |
811 | ||
812 | when NE | Unknown => | |
813 | Set_Backwards_OK (N, False); | |
814 | Set_Forwards_OK (N, False); | |
ee6ba406 | 815 | end case; |
816 | end if; | |
817 | end if; | |
818 | ||
0650d72b | 819 | -- If after that analysis Loop_Required is False, meaning that we |
820 | -- have not discovered some non-overlap reason for requiring a loop, | |
821 | -- then the outcome depends on the capabilities of the back end. | |
ee6ba406 | 822 | |
823 | if not Loop_Required then | |
111399d1 | 824 | -- Assume the back end can deal with all cases of overlap by |
825 | -- falling back to memmove if it cannot use a more efficient | |
826 | -- approach. | |
46ed552e | 827 | |
111399d1 | 828 | return; |
ee6ba406 | 829 | end if; |
830 | ||
0524b5dd | 831 | -- At this stage we have to generate an explicit loop, and we have |
832 | -- the following cases: | |
ee6ba406 | 833 | |
834 | -- Forwards_OK = True | |
835 | ||
836 | -- Rnn : right_index := right_index'First; | |
837 | -- for Lnn in left-index loop | |
838 | -- left (Lnn) := right (Rnn); | |
839 | -- Rnn := right_index'Succ (Rnn); | |
840 | -- end loop; | |
841 | ||
0524b5dd | 842 | -- Note: the above code MUST be analyzed with checks off, because |
843 | -- otherwise the Succ could overflow. But in any case this is more | |
39a0c1d3 | 844 | -- efficient. |
ee6ba406 | 845 | |
846 | -- Forwards_OK = False, Backwards_OK = True | |
847 | ||
848 | -- Rnn : right_index := right_index'Last; | |
849 | -- for Lnn in reverse left-index loop | |
850 | -- left (Lnn) := right (Rnn); | |
851 | -- Rnn := right_index'Pred (Rnn); | |
852 | -- end loop; | |
853 | ||
0524b5dd | 854 | -- Note: the above code MUST be analyzed with checks off, because |
855 | -- otherwise the Pred could overflow. But in any case this is more | |
39a0c1d3 | 856 | -- efficient. |
ee6ba406 | 857 | |
858 | -- Forwards_OK = Backwards_OK = False | |
859 | ||
860 | -- This only happens if we have the same array on each side. It is | |
861 | -- possible to create situations using overlays that violate this, | |
862 | -- but we simply do not promise to get this "right" in this case. | |
863 | ||
864 | -- There are two possible subcases. If the No_Implicit_Conditionals | |
865 | -- restriction is set, then we generate the following code: | |
866 | ||
867 | -- declare | |
868 | -- T : constant <operand-type> := rhs; | |
869 | -- begin | |
870 | -- lhs := T; | |
871 | -- end; | |
872 | ||
873 | -- If implicit conditionals are permitted, then we generate: | |
874 | ||
875 | -- if Left_Lo <= Right_Lo then | |
876 | -- <code for Forwards_OK = True above> | |
877 | -- else | |
878 | -- <code for Backwards_OK = True above> | |
879 | -- end if; | |
880 | ||
a2feb922 | 881 | -- In order to detect possible aliasing, we examine the renamed |
882 | -- expression when the source or target is a renaming. However, | |
883 | -- the renaming may be intended to capture an address that may be | |
884 | -- affected by subsequent code, and therefore we must recover | |
885 | -- the actual entity for the expansion that follows, not the | |
886 | -- object it renames. In particular, if source or target designate | |
887 | -- a portion of a dynamically allocated object, the pointer to it | |
888 | -- may be reassigned but the renaming preserves the proper location. | |
889 | ||
890 | if Is_Entity_Name (Rhs) | |
891 | and then | |
892 | Nkind (Parent (Entity (Rhs))) = N_Object_Renaming_Declaration | |
893 | and then Nkind (Act_Rhs) = N_Slice | |
894 | then | |
895 | Rarray := Rhs; | |
896 | end if; | |
897 | ||
898 | if Is_Entity_Name (Lhs) | |
899 | and then | |
900 | Nkind (Parent (Entity (Lhs))) = N_Object_Renaming_Declaration | |
901 | and then Nkind (Act_Lhs) = N_Slice | |
902 | then | |
903 | Larray := Lhs; | |
904 | end if; | |
905 | ||
ee6ba406 | 906 | -- Cases where either Forwards_OK or Backwards_OK is true |
907 | ||
908 | if Forwards_OK (N) or else Backwards_OK (N) then | |
45851103 | 909 | if Needs_Finalization (Component_Type (L_Type)) |
bd550baf | 910 | and then Base_Type (L_Type) = Base_Type (R_Type) |
911 | and then Ndim = 1 | |
912 | and then not No_Ctrl_Actions (N) | |
913 | then | |
914 | declare | |
4644a919 | 915 | Proc : constant Entity_Id := |
916 | TSS (Base_Type (L_Type), TSS_Slice_Assign); | |
bd550baf | 917 | Actuals : List_Id; |
918 | ||
919 | begin | |
920 | Apply_Dereference (Larray); | |
921 | Apply_Dereference (Rarray); | |
922 | Actuals := New_List ( | |
923 | Duplicate_Subexpr (Larray, Name_Req => True), | |
924 | Duplicate_Subexpr (Rarray, Name_Req => True), | |
925 | Duplicate_Subexpr (Left_Lo, Name_Req => True), | |
926 | Duplicate_Subexpr (Left_Hi, Name_Req => True), | |
927 | Duplicate_Subexpr (Right_Lo, Name_Req => True), | |
928 | Duplicate_Subexpr (Right_Hi, Name_Req => True)); | |
929 | ||
1bbc9831 | 930 | Append_To (Actuals, |
931 | New_Occurrence_Of ( | |
932 | Boolean_Literals (not Forwards_OK (N)), Loc)); | |
bd550baf | 933 | |
934 | Rewrite (N, | |
935 | Make_Procedure_Call_Statement (Loc, | |
83c6c069 | 936 | Name => New_Occurrence_Of (Proc, Loc), |
bd550baf | 937 | Parameter_Associations => Actuals)); |
938 | end; | |
939 | ||
940 | else | |
941 | Rewrite (N, | |
942 | Expand_Assign_Array_Loop | |
943 | (N, Larray, Rarray, L_Type, R_Type, Ndim, | |
944 | Rev => not Forwards_OK (N))); | |
945 | end if; | |
ee6ba406 | 946 | |
947 | -- Case of both are false with No_Implicit_Conditionals | |
948 | ||
1e16c51c | 949 | elsif Restriction_Active (No_Implicit_Conditionals) then |
ee6ba406 | 950 | declare |
5c61a0ff | 951 | T : constant Entity_Id := |
952 | Make_Defining_Identifier (Loc, Chars => Name_T); | |
ee6ba406 | 953 | |
954 | begin | |
955 | Rewrite (N, | |
956 | Make_Block_Statement (Loc, | |
957 | Declarations => New_List ( | |
958 | Make_Object_Declaration (Loc, | |
959 | Defining_Identifier => T, | |
960 | Constant_Present => True, | |
961 | Object_Definition => | |
962 | New_Occurrence_Of (Etype (Rhs), Loc), | |
963 | Expression => Relocate_Node (Rhs))), | |
964 | ||
965 | Handled_Statement_Sequence => | |
966 | Make_Handled_Sequence_Of_Statements (Loc, | |
967 | Statements => New_List ( | |
968 | Make_Assignment_Statement (Loc, | |
969 | Name => Relocate_Node (Lhs), | |
970 | Expression => New_Occurrence_Of (T, Loc)))))); | |
971 | end; | |
972 | ||
973 | -- Case of both are false with implicit conditionals allowed | |
974 | ||
975 | else | |
0524b5dd | 976 | -- Before we generate this code, we must ensure that the left and |
977 | -- right side array types are defined. They may be itypes, and we | |
978 | -- cannot let them be defined inside the if, since the first use | |
979 | -- in the then may not be executed. | |
ee6ba406 | 980 | |
981 | Ensure_Defined (L_Type, N); | |
982 | Ensure_Defined (R_Type, N); | |
983 | ||
0524b5dd | 984 | -- We normally compare addresses to find out which way round to |
36b938a3 | 985 | -- do the loop, since this is reliable, and handles the cases of |
0524b5dd | 986 | -- parameters, conversions etc. But we can't do that in the bit |
36ac5fbb | 987 | -- packed case, because addresses don't work there. |
ee6ba406 | 988 | |
36ac5fbb | 989 | if not Is_Bit_Packed_Array (L_Type) then |
ee6ba406 | 990 | Condition := |
991 | Make_Op_Le (Loc, | |
992 | Left_Opnd => | |
993 | Unchecked_Convert_To (RTE (RE_Integer_Address), | |
994 | Make_Attribute_Reference (Loc, | |
995 | Prefix => | |
996 | Make_Indexed_Component (Loc, | |
997 | Prefix => | |
9dfe12ae | 998 | Duplicate_Subexpr_Move_Checks (Larray, True), |
ee6ba406 | 999 | Expressions => New_List ( |
1000 | Make_Attribute_Reference (Loc, | |
1001 | Prefix => | |
83c6c069 | 1002 | New_Occurrence_Of |
ee6ba406 | 1003 | (L_Index_Typ, Loc), |
1004 | Attribute_Name => Name_First))), | |
1005 | Attribute_Name => Name_Address)), | |
1006 | ||
1007 | Right_Opnd => | |
1008 | Unchecked_Convert_To (RTE (RE_Integer_Address), | |
1009 | Make_Attribute_Reference (Loc, | |
1010 | Prefix => | |
1011 | Make_Indexed_Component (Loc, | |
1012 | Prefix => | |
9dfe12ae | 1013 | Duplicate_Subexpr_Move_Checks (Rarray, True), |
ee6ba406 | 1014 | Expressions => New_List ( |
1015 | Make_Attribute_Reference (Loc, | |
1016 | Prefix => | |
83c6c069 | 1017 | New_Occurrence_Of |
ee6ba406 | 1018 | (R_Index_Typ, Loc), |
1019 | Attribute_Name => Name_First))), | |
1020 | Attribute_Name => Name_Address))); | |
1021 | ||
0524b5dd | 1022 | -- For the bit packed and VM cases we use the bounds. That's OK, |
1023 | -- because we don't have to worry about parameters, since they | |
1024 | -- cannot cause overlap. Perhaps we should worry about weird slice | |
1025 | -- conversions ??? | |
ee6ba406 | 1026 | |
1027 | else | |
d21d7832 | 1028 | -- Copy the bounds |
ee6ba406 | 1029 | |
1030 | Cleft_Lo := New_Copy_Tree (Left_Lo); | |
1031 | Cright_Lo := New_Copy_Tree (Right_Lo); | |
d21d7832 | 1032 | |
1033 | -- If the types do not match we add an implicit conversion | |
1034 | -- here to ensure proper match | |
1035 | ||
1036 | if Etype (Left_Lo) /= Etype (Right_Lo) then | |
1037 | Cright_Lo := | |
1038 | Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo); | |
1039 | end if; | |
1040 | ||
1041 | -- Reset the Analyzed flag, because the bounds of the index | |
6fb3c314 | 1042 | -- type itself may be universal, and must must be reanalyzed |
d21d7832 | 1043 | -- to acquire the proper type for the back end. |
1044 | ||
ee6ba406 | 1045 | Set_Analyzed (Cleft_Lo, False); |
1046 | Set_Analyzed (Cright_Lo, False); | |
1047 | ||
1048 | Condition := | |
1049 | Make_Op_Le (Loc, | |
1050 | Left_Opnd => Cleft_Lo, | |
1051 | Right_Opnd => Cright_Lo); | |
1052 | end if; | |
1053 | ||
45851103 | 1054 | if Needs_Finalization (Component_Type (L_Type)) |
bd550baf | 1055 | and then Base_Type (L_Type) = Base_Type (R_Type) |
1056 | and then Ndim = 1 | |
1057 | and then not No_Ctrl_Actions (N) | |
1058 | then | |
ee6ba406 | 1059 | |
36b938a3 | 1060 | -- Call TSS procedure for array assignment, passing the |
7748ccb2 | 1061 | -- explicit bounds of right- and left-hand sides. |
bd550baf | 1062 | |
1063 | declare | |
4644a919 | 1064 | Proc : constant Entity_Id := |
c54e9270 | 1065 | TSS (Base_Type (L_Type), TSS_Slice_Assign); |
bd550baf | 1066 | Actuals : List_Id; |
1067 | ||
1068 | begin | |
1069 | Apply_Dereference (Larray); | |
1070 | Apply_Dereference (Rarray); | |
1071 | Actuals := New_List ( | |
1072 | Duplicate_Subexpr (Larray, Name_Req => True), | |
1073 | Duplicate_Subexpr (Rarray, Name_Req => True), | |
1074 | Duplicate_Subexpr (Left_Lo, Name_Req => True), | |
1075 | Duplicate_Subexpr (Left_Hi, Name_Req => True), | |
1076 | Duplicate_Subexpr (Right_Lo, Name_Req => True), | |
1077 | Duplicate_Subexpr (Right_Hi, Name_Req => True)); | |
c54e9270 | 1078 | |
1079 | Append_To (Actuals, | |
1080 | Make_Op_Not (Loc, | |
1081 | Right_Opnd => Condition)); | |
bd550baf | 1082 | |
1083 | Rewrite (N, | |
1084 | Make_Procedure_Call_Statement (Loc, | |
83c6c069 | 1085 | Name => New_Occurrence_Of (Proc, Loc), |
bd550baf | 1086 | Parameter_Associations => Actuals)); |
1087 | end; | |
ee6ba406 | 1088 | |
bd550baf | 1089 | else |
1090 | Rewrite (N, | |
1091 | Make_Implicit_If_Statement (N, | |
1092 | Condition => Condition, | |
1093 | ||
1094 | Then_Statements => New_List ( | |
1095 | Expand_Assign_Array_Loop | |
1096 | (N, Larray, Rarray, L_Type, R_Type, Ndim, | |
1097 | Rev => False)), | |
1098 | ||
1099 | Else_Statements => New_List ( | |
1100 | Expand_Assign_Array_Loop | |
1101 | (N, Larray, Rarray, L_Type, R_Type, Ndim, | |
1102 | Rev => True)))); | |
1103 | end if; | |
ee6ba406 | 1104 | end if; |
1105 | ||
1106 | Analyze (N, Suppress => All_Checks); | |
1107 | end; | |
9dfe12ae | 1108 | |
1109 | exception | |
1110 | when RE_Not_Available => | |
1111 | return; | |
ee6ba406 | 1112 | end Expand_Assign_Array; |
1113 | ||
1114 | ------------------------------ | |
1115 | -- Expand_Assign_Array_Loop -- | |
1116 | ------------------------------ | |
1117 | ||
0524b5dd | 1118 | -- The following is an example of the loop generated for the case of a |
1119 | -- two-dimensional array: | |
ee6ba406 | 1120 | |
1121 | -- declare | |
1122 | -- R2b : Tm1X1 := 1; | |
1123 | -- begin | |
1124 | -- for L1b in 1 .. 100 loop | |
1125 | -- declare | |
1126 | -- R4b : Tm1X2 := 1; | |
1127 | -- begin | |
1128 | -- for L3b in 1 .. 100 loop | |
1129 | -- vm1 (L1b, L3b) := vm2 (R2b, R4b); | |
1130 | -- R4b := Tm1X2'succ(R4b); | |
1131 | -- end loop; | |
1132 | -- end; | |
1133 | -- R2b := Tm1X1'succ(R2b); | |
1134 | -- end loop; | |
1135 | -- end; | |
1136 | ||
7748ccb2 | 1137 | -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand |
0524b5dd | 1138 | -- side. The declarations of R2b and R4b are inserted before the original |
1139 | -- assignment statement. | |
ee6ba406 | 1140 | |
1141 | function Expand_Assign_Array_Loop | |
1142 | (N : Node_Id; | |
1143 | Larray : Entity_Id; | |
1144 | Rarray : Entity_Id; | |
1145 | L_Type : Entity_Id; | |
1146 | R_Type : Entity_Id; | |
1147 | Ndim : Pos; | |
5c61a0ff | 1148 | Rev : Boolean) return Node_Id |
ee6ba406 | 1149 | is |
1150 | Loc : constant Source_Ptr := Sloc (N); | |
1151 | ||
1152 | Lnn : array (1 .. Ndim) of Entity_Id; | |
1153 | Rnn : array (1 .. Ndim) of Entity_Id; | |
1154 | -- Entities used as subscripts on left and right sides | |
1155 | ||
1156 | L_Index_Type : array (1 .. Ndim) of Entity_Id; | |
1157 | R_Index_Type : array (1 .. Ndim) of Entity_Id; | |
1158 | -- Left and right index types | |
1159 | ||
1160 | Assign : Node_Id; | |
1161 | ||
1162 | F_Or_L : Name_Id; | |
1163 | S_Or_P : Name_Id; | |
1164 | ||
c2b89d6e | 1165 | function Build_Step (J : Nat) return Node_Id; |
f3dfb204 | 1166 | -- The increment step for the index of the right-hand side is written |
1167 | -- as an attribute reference (Succ or Pred). This function returns | |
1b8f5136 | 1168 | -- the corresponding node, which is placed at the end of the loop body. |
c2b89d6e | 1169 | |
1170 | ---------------- | |
1171 | -- Build_Step -- | |
1172 | ---------------- | |
1173 | ||
1174 | function Build_Step (J : Nat) return Node_Id is | |
1175 | Step : Node_Id; | |
1176 | Lim : Name_Id; | |
1177 | ||
1178 | begin | |
1179 | if Rev then | |
1180 | Lim := Name_First; | |
1181 | else | |
1182 | Lim := Name_Last; | |
1183 | end if; | |
1184 | ||
1185 | Step := | |
1186 | Make_Assignment_Statement (Loc, | |
1187 | Name => New_Occurrence_Of (Rnn (J), Loc), | |
1188 | Expression => | |
1189 | Make_Attribute_Reference (Loc, | |
1190 | Prefix => | |
1191 | New_Occurrence_Of (R_Index_Type (J), Loc), | |
1192 | Attribute_Name => S_Or_P, | |
1193 | Expressions => New_List ( | |
1194 | New_Occurrence_Of (Rnn (J), Loc)))); | |
1195 | ||
1b8f5136 | 1196 | -- Note that on the last iteration of the loop, the index is increased |
1197 | -- (or decreased) past the corresponding bound. This is consistent with | |
1198 | -- the C semantics of the back-end, where such an off-by-one value on a | |
cc0baf29 | 1199 | -- dead index variable is OK. However, in CodePeer mode this leads to |
1b8f5136 | 1200 | -- spurious warnings, and thus we place a guard around the attribute |
1201 | -- reference. For obvious reasons we only do this for CodePeer. | |
1202 | ||
c2b89d6e | 1203 | if CodePeer_Mode then |
1204 | Step := | |
1205 | Make_If_Statement (Loc, | |
1206 | Condition => | |
1207 | Make_Op_Ne (Loc, | |
1208 | Left_Opnd => New_Occurrence_Of (Lnn (J), Loc), | |
1209 | Right_Opnd => | |
1210 | Make_Attribute_Reference (Loc, | |
1211 | Prefix => New_Occurrence_Of (L_Index_Type (J), Loc), | |
1212 | Attribute_Name => Lim)), | |
1213 | Then_Statements => New_List (Step)); | |
1214 | end if; | |
1215 | ||
1216 | return Step; | |
1217 | end Build_Step; | |
1218 | ||
a35b881d | 1219 | -- Start of processing for Expand_Assign_Array_Loop |
1220 | ||
ee6ba406 | 1221 | begin |
1222 | if Rev then | |
1223 | F_Or_L := Name_Last; | |
1224 | S_Or_P := Name_Pred; | |
1225 | else | |
1226 | F_Or_L := Name_First; | |
1227 | S_Or_P := Name_Succ; | |
1228 | end if; | |
1229 | ||
1230 | -- Setup index types and subscript entities | |
1231 | ||
1232 | declare | |
1233 | L_Index : Node_Id; | |
1234 | R_Index : Node_Id; | |
1235 | ||
1236 | begin | |
1237 | L_Index := First_Index (L_Type); | |
1238 | R_Index := First_Index (R_Type); | |
1239 | ||
1240 | for J in 1 .. Ndim loop | |
e0394eca | 1241 | Lnn (J) := Make_Temporary (Loc, 'L'); |
1242 | Rnn (J) := Make_Temporary (Loc, 'R'); | |
ee6ba406 | 1243 | |
1244 | L_Index_Type (J) := Etype (L_Index); | |
1245 | R_Index_Type (J) := Etype (R_Index); | |
1246 | ||
1247 | Next_Index (L_Index); | |
1248 | Next_Index (R_Index); | |
1249 | end loop; | |
1250 | end; | |
1251 | ||
1252 | -- Now construct the assignment statement | |
1253 | ||
1254 | declare | |
9dfe12ae | 1255 | ExprL : constant List_Id := New_List; |
1256 | ExprR : constant List_Id := New_List; | |
ee6ba406 | 1257 | |
1258 | begin | |
1259 | for J in 1 .. Ndim loop | |
1260 | Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc)); | |
1261 | Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc)); | |
1262 | end loop; | |
1263 | ||
1264 | Assign := | |
1265 | Make_Assignment_Statement (Loc, | |
1266 | Name => | |
1267 | Make_Indexed_Component (Loc, | |
4660e715 | 1268 | Prefix => Duplicate_Subexpr (Larray, Name_Req => True), |
ee6ba406 | 1269 | Expressions => ExprL), |
1270 | Expression => | |
1271 | Make_Indexed_Component (Loc, | |
4660e715 | 1272 | Prefix => Duplicate_Subexpr (Rarray, Name_Req => True), |
ee6ba406 | 1273 | Expressions => ExprR)); |
1274 | ||
4660e715 | 1275 | -- We set assignment OK, since there are some cases, e.g. in object |
1276 | -- declarations, where we are actually assigning into a constant. | |
1277 | -- If there really is an illegality, it was caught long before now, | |
1278 | -- and was flagged when the original assignment was analyzed. | |
1279 | ||
1280 | Set_Assignment_OK (Name (Assign)); | |
1281 | ||
ee6ba406 | 1282 | -- Propagate the No_Ctrl_Actions flag to individual assignments |
1283 | ||
1284 | Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N)); | |
1285 | end; | |
1286 | ||
1287 | -- Now construct the loop from the inside out, with the last subscript | |
1288 | -- varying most rapidly. Note that Assign is first the raw assignment | |
1289 | -- statement, and then subsequently the loop that wraps it up. | |
1290 | ||
1291 | for J in reverse 1 .. Ndim loop | |
1292 | Assign := | |
1293 | Make_Block_Statement (Loc, | |
1294 | Declarations => New_List ( | |
1295 | Make_Object_Declaration (Loc, | |
1296 | Defining_Identifier => Rnn (J), | |
1297 | Object_Definition => | |
1298 | New_Occurrence_Of (R_Index_Type (J), Loc), | |
1299 | Expression => | |
1300 | Make_Attribute_Reference (Loc, | |
1301 | Prefix => New_Occurrence_Of (R_Index_Type (J), Loc), | |
1302 | Attribute_Name => F_Or_L))), | |
1303 | ||
1304 | Handled_Statement_Sequence => | |
1305 | Make_Handled_Sequence_Of_Statements (Loc, | |
1306 | Statements => New_List ( | |
1307 | Make_Implicit_Loop_Statement (N, | |
1308 | Iteration_Scheme => | |
1309 | Make_Iteration_Scheme (Loc, | |
1310 | Loop_Parameter_Specification => | |
1311 | Make_Loop_Parameter_Specification (Loc, | |
1312 | Defining_Identifier => Lnn (J), | |
1313 | Reverse_Present => Rev, | |
1314 | Discrete_Subtype_Definition => | |
83c6c069 | 1315 | New_Occurrence_Of (L_Index_Type (J), Loc))), |
ee6ba406 | 1316 | |
c2b89d6e | 1317 | Statements => New_List (Assign, Build_Step (J)))))); |
ee6ba406 | 1318 | end loop; |
1319 | ||
1320 | return Assign; | |
1321 | end Expand_Assign_Array_Loop; | |
1322 | ||
1323 | -------------------------- | |
1324 | -- Expand_Assign_Record -- | |
1325 | -------------------------- | |
1326 | ||
ee6ba406 | 1327 | procedure Expand_Assign_Record (N : Node_Id) is |
d2b860b4 | 1328 | Lhs : constant Node_Id := Name (N); |
1329 | Rhs : Node_Id := Expression (N); | |
1330 | L_Typ : constant Entity_Id := Base_Type (Etype (Lhs)); | |
b3fb26fd | 1331 | |
ee6ba406 | 1332 | begin |
7748ccb2 | 1333 | -- If change of representation, then extract the real right-hand side |
0524b5dd | 1334 | -- from the type conversion, and proceed with component-wise assignment, |
1335 | -- since the two types are not the same as far as the back end is | |
1336 | -- concerned. | |
b3fb26fd | 1337 | |
1338 | if Change_Of_Representation (N) then | |
1339 | Rhs := Expression (Rhs); | |
1340 | ||
0524b5dd | 1341 | -- If this may be a case of a large bit aligned component, then proceed |
1342 | -- with component-wise assignment, to avoid possible clobbering of other | |
1343 | -- components sharing bits in the first or last byte of the component to | |
1344 | -- be assigned. | |
b3fb26fd | 1345 | |
cf6d853e | 1346 | elsif Possible_Bit_Aligned_Component (Lhs) |
05e5286d | 1347 | or |
cf6d853e | 1348 | Possible_Bit_Aligned_Component (Rhs) |
05e5286d | 1349 | then |
b3fb26fd | 1350 | null; |
1351 | ||
d2b860b4 | 1352 | -- If we have a tagged type that has a complete record representation |
1353 | -- clause, we must do we must do component-wise assignments, since child | |
1354 | -- types may have used gaps for their components, and we might be | |
1355 | -- dealing with a view conversion. | |
1356 | ||
1357 | elsif Is_Fully_Repped_Tagged_Type (L_Typ) then | |
1358 | null; | |
1359 | ||
b3fb26fd | 1360 | -- If neither condition met, then nothing special to do, the back end |
1361 | -- can handle assignment of the entire component as a single entity. | |
1362 | ||
1363 | else | |
ee6ba406 | 1364 | return; |
1365 | end if; | |
1366 | ||
b3fb26fd | 1367 | -- At this stage we know that we must do a component wise assignment |
ee6ba406 | 1368 | |
1369 | declare | |
1370 | Loc : constant Source_Ptr := Sloc (N); | |
b3fb26fd | 1371 | R_Typ : constant Entity_Id := Base_Type (Etype (Rhs)); |
ee6ba406 | 1372 | Decl : constant Node_Id := Declaration_Node (R_Typ); |
1373 | RDef : Node_Id; | |
1374 | F : Entity_Id; | |
1375 | ||
1376 | function Find_Component | |
1377 | (Typ : Entity_Id; | |
b3fb26fd | 1378 | Comp : Entity_Id) return Entity_Id; |
ee6ba406 | 1379 | -- Find the component with the given name in the underlying record |
0524b5dd | 1380 | -- declaration for Typ. We need to use the actual entity because the |
1381 | -- type may be private and resolution by identifier alone would fail. | |
ee6ba406 | 1382 | |
00f91aef | 1383 | function Make_Component_List_Assign |
1384 | (CL : Node_Id; | |
1385 | U_U : Boolean := False) return List_Id; | |
ee6ba406 | 1386 | -- Returns a sequence of statements to assign the components that |
00f91aef | 1387 | -- are referenced in the given component list. The flag U_U is |
1388 | -- used to force the usage of the inferred value of the variant | |
1389 | -- part expression as the switch for the generated case statement. | |
1390 | ||
1391 | function Make_Field_Assign | |
cc0baf29 | 1392 | (C : Entity_Id; |
00f91aef | 1393 | U_U : Boolean := False) return Node_Id; |
1394 | -- Given C, the entity for a discriminant or component, build an | |
1395 | -- assignment for the corresponding field values. The flag U_U | |
1396 | -- signals the presence of an Unchecked_Union and forces the usage | |
7748ccb2 | 1397 | -- of the inferred discriminant value of C as the right-hand side |
00f91aef | 1398 | -- of the assignment. |
ee6ba406 | 1399 | |
1400 | function Make_Field_Assigns (CI : List_Id) return List_Id; | |
1401 | -- Given CI, a component items list, construct series of statements | |
1402 | -- for fieldwise assignment of the corresponding components. | |
1403 | ||
1404 | -------------------- | |
1405 | -- Find_Component -- | |
1406 | -------------------- | |
1407 | ||
1408 | function Find_Component | |
1409 | (Typ : Entity_Id; | |
b3fb26fd | 1410 | Comp : Entity_Id) return Entity_Id |
ee6ba406 | 1411 | is |
1412 | Utyp : constant Entity_Id := Underlying_Type (Typ); | |
1413 | C : Entity_Id; | |
1414 | ||
1415 | begin | |
1416 | C := First_Entity (Utyp); | |
ee6ba406 | 1417 | while Present (C) loop |
1418 | if Chars (C) = Chars (Comp) then | |
1419 | return C; | |
1420 | end if; | |
d2b860b4 | 1421 | |
ee6ba406 | 1422 | Next_Entity (C); |
1423 | end loop; | |
1424 | ||
1425 | raise Program_Error; | |
1426 | end Find_Component; | |
1427 | ||
1428 | -------------------------------- | |
1429 | -- Make_Component_List_Assign -- | |
1430 | -------------------------------- | |
1431 | ||
00f91aef | 1432 | function Make_Component_List_Assign |
1433 | (CL : Node_Id; | |
1434 | U_U : Boolean := False) return List_Id | |
1435 | is | |
ee6ba406 | 1436 | CI : constant List_Id := Component_Items (CL); |
1437 | VP : constant Node_Id := Variant_Part (CL); | |
1438 | ||
ee6ba406 | 1439 | Alts : List_Id; |
ee6ba406 | 1440 | DC : Node_Id; |
1441 | DCH : List_Id; | |
cd3c2a98 | 1442 | Expr : Node_Id; |
00f91aef | 1443 | Result : List_Id; |
1444 | V : Node_Id; | |
ee6ba406 | 1445 | |
1446 | begin | |
1447 | Result := Make_Field_Assigns (CI); | |
1448 | ||
1449 | if Present (VP) then | |
ee6ba406 | 1450 | V := First_Non_Pragma (Variants (VP)); |
1451 | Alts := New_List; | |
1452 | while Present (V) loop | |
ee6ba406 | 1453 | DCH := New_List; |
1454 | DC := First (Discrete_Choices (V)); | |
1455 | while Present (DC) loop | |
1456 | Append_To (DCH, New_Copy_Tree (DC)); | |
1457 | Next (DC); | |
1458 | end loop; | |
1459 | ||
1460 | Append_To (Alts, | |
1461 | Make_Case_Statement_Alternative (Loc, | |
1462 | Discrete_Choices => DCH, | |
1463 | Statements => | |
1464 | Make_Component_List_Assign (Component_List (V)))); | |
1465 | Next_Non_Pragma (V); | |
1466 | end loop; | |
1467 | ||
cd3c2a98 | 1468 | -- If we have an Unchecked_Union, use the value of the inferred |
1469 | -- discriminant of the variant part expression as the switch | |
1470 | -- for the case statement. The case statement may later be | |
1471 | -- folded. | |
1472 | ||
1473 | if U_U then | |
1474 | Expr := | |
1475 | New_Copy (Get_Discriminant_Value ( | |
1476 | Entity (Name (VP)), | |
1477 | Etype (Rhs), | |
1478 | Discriminant_Constraint (Etype (Rhs)))); | |
1479 | else | |
1480 | Expr := | |
1481 | Make_Selected_Component (Loc, | |
55868293 | 1482 | Prefix => Duplicate_Subexpr (Rhs), |
cd3c2a98 | 1483 | Selector_Name => |
1484 | Make_Identifier (Loc, Chars (Name (VP)))); | |
1485 | end if; | |
1486 | ||
ee6ba406 | 1487 | Append_To (Result, |
1488 | Make_Case_Statement (Loc, | |
cd3c2a98 | 1489 | Expression => Expr, |
ee6ba406 | 1490 | Alternatives => Alts)); |
ee6ba406 | 1491 | end if; |
1492 | ||
1493 | return Result; | |
1494 | end Make_Component_List_Assign; | |
1495 | ||
1496 | ----------------------- | |
1497 | -- Make_Field_Assign -- | |
1498 | ----------------------- | |
1499 | ||
00f91aef | 1500 | function Make_Field_Assign |
cc0baf29 | 1501 | (C : Entity_Id; |
00f91aef | 1502 | U_U : Boolean := False) return Node_Id |
1503 | is | |
1504 | A : Node_Id; | |
9600e689 | 1505 | Disc : Entity_Id; |
cd3c2a98 | 1506 | Expr : Node_Id; |
ee6ba406 | 1507 | |
1508 | begin | |
9600e689 | 1509 | -- The discriminant entity to be used in the retrieval below must |
a740d7fa | 1510 | -- be one in the corresponding type, given that the assignment may |
1511 | -- be between derived and parent types. | |
9600e689 | 1512 | |
1513 | if Is_Derived_Type (Etype (Rhs)) then | |
1514 | Disc := Find_Component (R_Typ, C); | |
1515 | else | |
1516 | Disc := C; | |
1517 | end if; | |
1518 | ||
00f91aef | 1519 | -- In the case of an Unchecked_Union, use the discriminant |
7748ccb2 | 1520 | -- constraint value as on the right-hand side of the assignment. |
00f91aef | 1521 | |
cd3c2a98 | 1522 | if U_U then |
1523 | Expr := | |
1524 | New_Copy (Get_Discriminant_Value (C, | |
1525 | Etype (Rhs), | |
1526 | Discriminant_Constraint (Etype (Rhs)))); | |
1527 | else | |
1528 | Expr := | |
1529 | Make_Selected_Component (Loc, | |
4c58ddd7 | 1530 | Prefix => Duplicate_Subexpr (Rhs), |
9600e689 | 1531 | Selector_Name => New_Occurrence_Of (Disc, Loc)); |
cd3c2a98 | 1532 | end if; |
1533 | ||
1ace4a8b | 1534 | -- Generate the assignment statement. When the left-hand side |
1535 | -- is an object with an address clause present, force generated | |
1536 | -- temporaries to be renamings so as to correctly assign to any | |
1537 | -- overlaid objects. | |
1538 | ||
ee6ba406 | 1539 | A := |
1540 | Make_Assignment_Statement (Loc, | |
f81a201b | 1541 | Name => |
ee6ba406 | 1542 | Make_Selected_Component (Loc, |
1ace4a8b | 1543 | Prefix => |
1544 | Duplicate_Subexpr | |
1545 | (Exp => Lhs, | |
1546 | Name_Req => False, | |
1547 | Renaming_Req => | |
1548 | Is_Entity_Name (Lhs) | |
1549 | and then Present (Address_Clause (Entity (Lhs)))), | |
ee6ba406 | 1550 | Selector_Name => |
1551 | New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), | |
cd3c2a98 | 1552 | Expression => Expr); |
ee6ba406 | 1553 | |
1554 | -- Set Assignment_OK, so discriminants can be assigned | |
1555 | ||
1556 | Set_Assignment_OK (Name (A), True); | |
d2b860b4 | 1557 | |
1558 | if Componentwise_Assignment (N) | |
1559 | and then Nkind (Name (A)) = N_Selected_Component | |
1560 | and then Chars (Selector_Name (Name (A))) = Name_uParent | |
1561 | then | |
1562 | Set_Componentwise_Assignment (A); | |
1563 | end if; | |
1564 | ||
ee6ba406 | 1565 | return A; |
1566 | end Make_Field_Assign; | |
1567 | ||
1568 | ------------------------ | |
1569 | -- Make_Field_Assigns -- | |
1570 | ------------------------ | |
1571 | ||
1572 | function Make_Field_Assigns (CI : List_Id) return List_Id is | |
1573 | Item : Node_Id; | |
1574 | Result : List_Id; | |
1575 | ||
1576 | begin | |
cc0baf29 | 1577 | Item := First (CI); |
cd3c2a98 | 1578 | Result := New_List; |
1579 | ||
ee6ba406 | 1580 | while Present (Item) loop |
d2b860b4 | 1581 | |
1582 | -- Look for components, but exclude _tag field assignment if | |
1583 | -- the special Componentwise_Assignment flag is set. | |
1584 | ||
1585 | if Nkind (Item) = N_Component_Declaration | |
1586 | and then not (Is_Tag (Defining_Identifier (Item)) | |
cc0baf29 | 1587 | and then Componentwise_Assignment (N)) |
d2b860b4 | 1588 | then |
ee6ba406 | 1589 | Append_To |
1590 | (Result, Make_Field_Assign (Defining_Identifier (Item))); | |
1591 | end if; | |
1592 | ||
1593 | Next (Item); | |
1594 | end loop; | |
1595 | ||
1596 | return Result; | |
1597 | end Make_Field_Assigns; | |
1598 | ||
1599 | -- Start of processing for Expand_Assign_Record | |
1600 | ||
1601 | begin | |
9dfe12ae | 1602 | -- Note that we use the base types for this processing. This results |
ee6ba406 | 1603 | -- in some extra work in the constrained case, but the change of |
1604 | -- representation case is so unusual that it is not worth the effort. | |
1605 | ||
1606 | -- First copy the discriminants. This is done unconditionally. It | |
1607 | -- is required in the unconstrained left side case, and also in the | |
1608 | -- case where this assignment was constructed during the expansion | |
1609 | -- of a type conversion (since initialization of discriminants is | |
1610 | -- suppressed in this case). It is unnecessary but harmless in | |
1611 | -- other cases. | |
1612 | ||
b11290d7 | 1613 | -- Special case: no copy if the target has no discriminants |
2110b8e6 | 1614 | |
1615 | if Has_Discriminants (L_Typ) | |
1616 | and then Is_Unchecked_Union (Base_Type (L_Typ)) | |
1617 | then | |
1618 | null; | |
1619 | ||
1620 | elsif Has_Discriminants (L_Typ) then | |
ee6ba406 | 1621 | F := First_Discriminant (R_Typ); |
1622 | while Present (F) loop | |
00f91aef | 1623 | |
0318d457 | 1624 | -- If we are expanding the initialization of a derived record |
1625 | -- that constrains or renames discriminants of the parent, we | |
1626 | -- must use the corresponding discriminant in the parent. | |
1627 | ||
1628 | declare | |
1629 | CF : Entity_Id; | |
1630 | ||
1631 | begin | |
1632 | if Inside_Init_Proc | |
1633 | and then Present (Corresponding_Discriminant (F)) | |
1634 | then | |
1635 | CF := Corresponding_Discriminant (F); | |
1636 | else | |
1637 | CF := F; | |
1638 | end if; | |
1639 | ||
1640 | if Is_Unchecked_Union (Base_Type (R_Typ)) then | |
c19abba7 | 1641 | |
1642 | -- Within an initialization procedure this is the | |
1643 | -- assignment to an unchecked union component, in which | |
1644 | -- case there is no discriminant to initialize. | |
1645 | ||
1646 | if Inside_Init_Proc then | |
1647 | null; | |
1648 | ||
1649 | else | |
1650 | -- The assignment is part of a conversion from a | |
1651 | -- derived unchecked union type with an inferable | |
1652 | -- discriminant, to a parent type. | |
1653 | ||
1654 | Insert_Action (N, Make_Field_Assign (CF, True)); | |
1655 | end if; | |
1656 | ||
0318d457 | 1657 | else |
1658 | Insert_Action (N, Make_Field_Assign (CF)); | |
1659 | end if; | |
00f91aef | 1660 | |
0318d457 | 1661 | Next_Discriminant (F); |
1662 | end; | |
ee6ba406 | 1663 | end loop; |
8ae779b8 | 1664 | |
1665 | -- If the derived type has a stored constraint, assign the value | |
1666 | -- of the corresponding discriminants explicitly, skipping those | |
1667 | -- that are renamed discriminants. We cannot just retrieve them | |
1668 | -- from the Rhs by selected component because they are invisible | |
1669 | -- in the type of the right-hand side. | |
1670 | ||
1671 | if Stored_Constraint (R_Typ) /= No_Elist then | |
1672 | declare | |
8ae779b8 | 1673 | Assign : Node_Id; |
a740d7fa | 1674 | Discr_Val : Elmt_Id; |
8ae779b8 | 1675 | |
1676 | begin | |
1677 | Discr_Val := First_Elmt (Stored_Constraint (R_Typ)); | |
1678 | F := First_Entity (R_Typ); | |
1679 | while Present (F) loop | |
1680 | if Ekind (F) = E_Discriminant | |
1681 | and then Is_Completely_Hidden (F) | |
1682 | and then Present (Corresponding_Record_Component (F)) | |
a740d7fa | 1683 | and then |
1684 | (not Is_Entity_Name (Node (Discr_Val)) | |
1685 | or else Ekind (Entity (Node (Discr_Val))) /= | |
1686 | E_Discriminant) | |
8ae779b8 | 1687 | then |
1688 | Assign := | |
1689 | Make_Assignment_Statement (Loc, | |
a740d7fa | 1690 | Name => |
8ae779b8 | 1691 | Make_Selected_Component (Loc, |
1692 | Prefix => Duplicate_Subexpr (Lhs), | |
1693 | Selector_Name => | |
1694 | New_Occurrence_Of | |
1695 | (Corresponding_Record_Component (F), Loc)), | |
a740d7fa | 1696 | Expression => New_Copy (Node (Discr_Val))); |
8ae779b8 | 1697 | |
1698 | Set_Assignment_OK (Name (Assign)); | |
1699 | Insert_Action (N, Assign); | |
1700 | Next_Elmt (Discr_Val); | |
1701 | end if; | |
1702 | ||
1703 | Next_Entity (F); | |
1704 | end loop; | |
1705 | end; | |
1706 | end if; | |
ee6ba406 | 1707 | end if; |
1708 | ||
1709 | -- We know the underlying type is a record, but its current view | |
1710 | -- may be private. We must retrieve the usable record declaration. | |
1711 | ||
d2b860b4 | 1712 | if Nkind_In (Decl, N_Private_Type_Declaration, |
1713 | N_Private_Extension_Declaration) | |
ee6ba406 | 1714 | and then Present (Full_View (R_Typ)) |
1715 | then | |
1716 | RDef := Type_Definition (Declaration_Node (Full_View (R_Typ))); | |
1717 | else | |
1718 | RDef := Type_Definition (Decl); | |
1719 | end if; | |
1720 | ||
d2b860b4 | 1721 | if Nkind (RDef) = N_Derived_Type_Definition then |
1722 | RDef := Record_Extension_Part (RDef); | |
1723 | end if; | |
1724 | ||
ee6ba406 | 1725 | if Nkind (RDef) = N_Record_Definition |
1726 | and then Present (Component_List (RDef)) | |
1727 | then | |
00f91aef | 1728 | if Is_Unchecked_Union (R_Typ) then |
1729 | Insert_Actions (N, | |
1730 | Make_Component_List_Assign (Component_List (RDef), True)); | |
1731 | else | |
1732 | Insert_Actions | |
1733 | (N, Make_Component_List_Assign (Component_List (RDef))); | |
1734 | end if; | |
ee6ba406 | 1735 | |
1736 | Rewrite (N, Make_Null_Statement (Loc)); | |
1737 | end if; | |
ee6ba406 | 1738 | end; |
1739 | end Expand_Assign_Record; | |
1740 | ||
0d105023 | 1741 | ------------------------------------- |
1742 | -- Expand_Assign_With_Target_Names -- | |
1743 | ------------------------------------- | |
1744 | ||
1745 | procedure Expand_Assign_With_Target_Names (N : Node_Id) is | |
7748ccb2 | 1746 | LHS : constant Node_Id := Name (N); |
1747 | LHS_Typ : constant Entity_Id := Etype (LHS); | |
1748 | Loc : constant Source_Ptr := Sloc (N); | |
1749 | RHS : constant Node_Id := Expression (N); | |
0d105023 | 1750 | |
7748ccb2 | 1751 | Ent : Entity_Id; |
1752 | -- The entity of the left-hand side | |
0d105023 | 1753 | |
7748ccb2 | 1754 | function Replace_Target (N : Node_Id) return Traverse_Result; |
0d105023 | 1755 | -- Replace occurrences of the target name by the proper entity: either |
1756 | -- the entity of the LHS in simple cases, or the formal of the | |
1757 | -- constructed procedure otherwise. | |
1758 | ||
1759 | -------------------- | |
1760 | -- Replace_Target -- | |
1761 | -------------------- | |
1762 | ||
7748ccb2 | 1763 | function Replace_Target (N : Node_Id) return Traverse_Result is |
0d105023 | 1764 | begin |
1765 | if Nkind (N) = N_Target_Name then | |
1766 | Rewrite (N, New_Occurrence_Of (Ent, Sloc (N))); | |
6b1f5205 | 1767 | |
1768 | -- The expression will be reanalyzed when the enclosing assignment | |
1769 | -- is reanalyzed, so reset the entity, which may be a temporary | |
1770 | -- created during analysis, e.g. a loop variable for an iterated | |
023e0007 | 1771 | -- component association. However, if entity is callable then |
1772 | -- resolution has established its proper identity (including in | |
1773 | -- rewritten prefixed calls) so we must preserve it. | |
6b1f5205 | 1774 | |
1775 | elsif Is_Entity_Name (N) then | |
023e0007 | 1776 | if Present (Entity (N)) |
1777 | and then not Is_Overloadable (Entity (N)) | |
1778 | then | |
1779 | Set_Entity (N, Empty); | |
1780 | end if; | |
0d105023 | 1781 | end if; |
1782 | ||
1783 | Set_Analyzed (N, False); | |
1784 | return OK; | |
1785 | end Replace_Target; | |
1786 | ||
1787 | procedure Replace_Target_Name is new Traverse_Proc (Replace_Target); | |
1788 | ||
7748ccb2 | 1789 | -- Local variables |
1790 | ||
1791 | New_RHS : Node_Id; | |
1792 | Proc_Id : Entity_Id; | |
0d105023 | 1793 | |
7748ccb2 | 1794 | -- Start of processing for Expand_Assign_With_Target_Names |
1795 | ||
1796 | begin | |
0d105023 | 1797 | New_RHS := New_Copy_Tree (RHS); |
1798 | ||
7748ccb2 | 1799 | -- The left-hand side is a direct name |
1800 | ||
0d105023 | 1801 | if Is_Entity_Name (LHS) |
7748ccb2 | 1802 | and then not Is_Renaming_Of_Object (Entity (LHS)) |
0d105023 | 1803 | then |
1804 | Ent := Entity (LHS); | |
1805 | Replace_Target_Name (New_RHS); | |
7748ccb2 | 1806 | |
1807 | -- Generate: | |
1808 | -- LHS := ... LHS ...; | |
1809 | ||
0d105023 | 1810 | Rewrite (N, |
1811 | Make_Assignment_Statement (Loc, | |
7748ccb2 | 1812 | Name => Relocate_Node (LHS), |
0d105023 | 1813 | Expression => New_RHS)); |
1814 | ||
7748ccb2 | 1815 | -- The left-hand side is not a direct name, but is side-effect free. |
1816 | -- Capture its value in a temporary to avoid multiple evaluations. | |
1817 | ||
0d105023 | 1818 | elsif Side_Effect_Free (LHS) then |
1819 | Ent := Make_Temporary (Loc, 'T'); | |
7748ccb2 | 1820 | Replace_Target_Name (New_RHS); |
1821 | ||
1822 | -- Generate: | |
1823 | -- T : LHS_Typ := LHS; | |
1824 | ||
0d105023 | 1825 | Insert_Before_And_Analyze (N, |
1826 | Make_Object_Declaration (Loc, | |
1827 | Defining_Identifier => Ent, | |
7748ccb2 | 1828 | Object_Definition => New_Occurrence_Of (LHS_Typ, Loc), |
0d105023 | 1829 | Expression => New_Copy_Tree (LHS))); |
7748ccb2 | 1830 | |
1831 | -- Generate: | |
1832 | -- LHS := ... T ...; | |
1833 | ||
0d105023 | 1834 | Rewrite (N, |
1835 | Make_Assignment_Statement (Loc, | |
7748ccb2 | 1836 | Name => Relocate_Node (LHS), |
0d105023 | 1837 | Expression => New_RHS)); |
1838 | ||
7748ccb2 | 1839 | -- Otherwise wrap the whole assignment statement in a procedure with an |
1840 | -- IN OUT parameter. The original assignment then becomes a call to the | |
1841 | -- procedure with the left-hand side as an actual. | |
1842 | ||
0d105023 | 1843 | else |
1844 | Ent := Make_Temporary (Loc, 'T'); | |
7748ccb2 | 1845 | Replace_Target_Name (New_RHS); |
0d105023 | 1846 | |
7748ccb2 | 1847 | -- Generate: |
1848 | -- procedure P (T : in out LHS_Typ) is | |
1849 | -- begin | |
1850 | -- T := ... T ...; | |
1851 | -- end P; | |
0d105023 | 1852 | |
7748ccb2 | 1853 | Proc_Id := Make_Temporary (Loc, 'P'); |
1854 | ||
1855 | Insert_Before_And_Analyze (N, | |
1856 | Make_Subprogram_Body (Loc, | |
1857 | Specification => | |
1858 | Make_Procedure_Specification (Loc, | |
1859 | Defining_Unit_Name => Proc_Id, | |
1860 | Parameter_Specifications => New_List ( | |
1861 | Make_Parameter_Specification (Loc, | |
1862 | Defining_Identifier => Ent, | |
1863 | In_Present => True, | |
1864 | Out_Present => True, | |
1865 | Parameter_Type => | |
1866 | New_Occurrence_Of (LHS_Typ, Loc)))), | |
1867 | ||
1868 | Declarations => Empty_List, | |
1869 | ||
1870 | Handled_Statement_Sequence => | |
1871 | Make_Handled_Sequence_Of_Statements (Loc, | |
1872 | Statements => New_List ( | |
1873 | Make_Assignment_Statement (Loc, | |
1874 | Name => New_Occurrence_Of (Ent, Loc), | |
1875 | Expression => New_RHS))))); | |
1876 | ||
1877 | -- Generate: | |
1878 | -- P (LHS); | |
1879 | ||
1880 | Rewrite (N, | |
1881 | Make_Procedure_Call_Statement (Loc, | |
1882 | Name => New_Occurrence_Of (Proc_Id, Loc), | |
1883 | Parameter_Associations => New_List (Relocate_Node (LHS)))); | |
0d105023 | 1884 | end if; |
1885 | ||
7748ccb2 | 1886 | -- Analyze rewritten node, either as assignment or procedure call |
0d105023 | 1887 | |
1888 | Analyze (N); | |
1889 | end Expand_Assign_With_Target_Names; | |
1890 | ||
ee6ba406 | 1891 | ----------------------------------- |
1892 | -- Expand_N_Assignment_Statement -- | |
1893 | ----------------------------------- | |
1894 | ||
4660e715 | 1895 | -- This procedure implements various cases where an assignment statement |
1896 | -- cannot just be passed on to the back end in untransformed state. | |
ee6ba406 | 1897 | |
1898 | procedure Expand_N_Assignment_Statement (N : Node_Id) is | |
41a3f747 | 1899 | Crep : constant Boolean := Change_Of_Representation (N); |
ee6ba406 | 1900 | Lhs : constant Node_Id := Name (N); |
f9e26ff7 | 1901 | Loc : constant Source_Ptr := Sloc (N); |
ee6ba406 | 1902 | Rhs : constant Node_Id := Expression (N); |
1903 | Typ : constant Entity_Id := Underlying_Type (Etype (Lhs)); | |
1904 | Exp : Node_Id; | |
1905 | ||
1906 | begin | |
d2b860b4 | 1907 | -- Special case to check right away, if the Componentwise_Assignment |
1908 | -- flag is set, this is a reanalysis from the expansion of the primitive | |
1909 | -- assignment procedure for a tagged type, and all we need to do is to | |
1910 | -- expand to assignment of components, because otherwise, we would get | |
1911 | -- infinite recursion (since this looks like a tagged assignment which | |
1912 | -- would normally try to *call* the primitive assignment procedure). | |
1913 | ||
1914 | if Componentwise_Assignment (N) then | |
1915 | Expand_Assign_Record (N); | |
1916 | return; | |
1917 | end if; | |
1918 | ||
9af28f61 | 1919 | -- Defend against invalid subscripts on left side if we are in standard |
1920 | -- validity checking mode. No need to do this if we are checking all | |
1921 | -- subscripts. | |
1922 | ||
1923 | -- Note that we do this right away, because there are some early return | |
1924 | -- paths in this procedure, and this is required on all paths. | |
1925 | ||
1926 | if Validity_Checks_On | |
1927 | and then Validity_Check_Default | |
1928 | and then not Validity_Check_Subscripts | |
1929 | then | |
1930 | Check_Valid_Lvalue_Subscripts (Lhs); | |
1931 | end if; | |
1932 | ||
0d105023 | 1933 | -- Separate expansion if RHS contain target names. Note that assignment |
1934 | -- may already have been expanded if RHS is aggregate. | |
1935 | ||
7748ccb2 | 1936 | if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then |
0d105023 | 1937 | Expand_Assign_With_Target_Names (N); |
1938 | return; | |
1939 | end if; | |
1940 | ||
0326143c | 1941 | -- Ada 2005 (AI-327): Handle assignment to priority of protected object |
1942 | ||
21ec6442 | 1943 | -- Rewrite an assignment to X'Priority into a run-time call |
0326143c | 1944 | |
1945 | -- For example: X'Priority := New_Prio_Expr; | |
1946 | -- ...is expanded into Set_Ceiling (X._Object, New_Prio_Expr); | |
1947 | ||
1948 | -- Note that although X'Priority is notionally an object, it is quite | |
1949 | -- deliberately not defined as an aliased object in the RM. This means | |
1950 | -- that it works fine to rewrite it as a call, without having to worry | |
1951 | -- about complications that would other arise from X'Priority'Access, | |
1952 | -- which is illegal, because of the lack of aliasing. | |
1953 | ||
de54c5ab | 1954 | if Ada_Version >= Ada_2005 then |
0326143c | 1955 | declare |
1956 | Call : Node_Id; | |
1957 | Conctyp : Entity_Id; | |
1958 | Ent : Entity_Id; | |
0326143c | 1959 | Subprg : Entity_Id; |
1960 | RT_Subprg_Name : Node_Id; | |
1961 | ||
1962 | begin | |
1963 | -- Handle chains of renamings | |
1964 | ||
1965 | Ent := Name (N); | |
1966 | while Nkind (Ent) in N_Has_Entity | |
1967 | and then Present (Entity (Ent)) | |
1968 | and then Present (Renamed_Object (Entity (Ent))) | |
1969 | loop | |
1970 | Ent := Renamed_Object (Entity (Ent)); | |
1971 | end loop; | |
1972 | ||
1973 | -- The attribute Priority applied to protected objects has been | |
236f09e1 | 1974 | -- previously expanded into a call to the Get_Ceiling run-time |
82eb6a0d | 1975 | -- subprogram. In restricted profiles this is not available. |
0326143c | 1976 | |
808ac3d8 | 1977 | if Is_Expanded_Priority_Attribute (Ent) then |
1978 | ||
0326143c | 1979 | -- Look for the enclosing concurrent type |
1980 | ||
1981 | Conctyp := Current_Scope; | |
1982 | while not Is_Concurrent_Type (Conctyp) loop | |
1983 | Conctyp := Scope (Conctyp); | |
1984 | end loop; | |
1985 | ||
1986 | pragma Assert (Is_Protected_Type (Conctyp)); | |
1987 | ||
1988 | -- Generate the first actual of the call | |
1989 | ||
1990 | Subprg := Current_Scope; | |
1991 | while not Present (Protected_Body_Subprogram (Subprg)) loop | |
1992 | Subprg := Scope (Subprg); | |
1993 | end loop; | |
1994 | ||
0326143c | 1995 | -- Select the appropriate run-time call |
1996 | ||
1997 | if Number_Entries (Conctyp) = 0 then | |
1998 | RT_Subprg_Name := | |
83c6c069 | 1999 | New_Occurrence_Of (RTE (RE_Set_Ceiling), Loc); |
0326143c | 2000 | else |
2001 | RT_Subprg_Name := | |
83c6c069 | 2002 | New_Occurrence_Of (RTE (RO_PE_Set_Ceiling), Loc); |
0326143c | 2003 | end if; |
2004 | ||
2005 | Call := | |
2006 | Make_Procedure_Call_Statement (Loc, | |
2007 | Name => RT_Subprg_Name, | |
236f09e1 | 2008 | Parameter_Associations => New_List ( |
2009 | New_Copy_Tree (First (Parameter_Associations (Ent))), | |
2010 | Relocate_Node (Expression (N)))); | |
0326143c | 2011 | |
2012 | Rewrite (N, Call); | |
2013 | Analyze (N); | |
f9e26ff7 | 2014 | |
0326143c | 2015 | return; |
2016 | end if; | |
2017 | end; | |
2018 | end if; | |
2019 | ||
55e8372b | 2020 | -- Deal with assignment checks unless suppressed |
9dfe12ae | 2021 | |
55e8372b | 2022 | if not Suppress_Assignment_Checks (N) then |
9dfe12ae | 2023 | |
180bd06b | 2024 | -- First deal with generation of range check if required, |
2025 | -- and then predicate checks if the type carries a predicate. | |
2026 | -- If the Rhs is an expression these tests may have been applied | |
2027 | -- already. This is the case if the RHS is a type conversion. | |
2028 | -- Other such redundant checks could be removed ??? | |
2029 | ||
2030 | if Nkind (Rhs) /= N_Type_Conversion | |
2031 | or else Entity (Subtype_Mark (Rhs)) /= Typ | |
2032 | then | |
2033 | if Do_Range_Check (Rhs) then | |
2034 | Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed); | |
2035 | end if; | |
55e8372b | 2036 | |
180bd06b | 2037 | Apply_Predicate_Check (Rhs, Typ); |
55e8372b | 2038 | end if; |
55e8372b | 2039 | end if; |
7aafae1c | 2040 | |
ee6ba406 | 2041 | -- Check for a special case where a high level transformation is |
2042 | -- required. If we have either of: | |
2043 | ||
2044 | -- P.field := rhs; | |
2045 | -- P (sub) := rhs; | |
2046 | ||
2047 | -- where P is a reference to a bit packed array, then we have to unwind | |
2048 | -- the assignment. The exact meaning of being a reference to a bit | |
2049 | -- packed array is as follows: | |
2050 | ||
2051 | -- An indexed component whose prefix is a bit packed array is a | |
0524b5dd | 2052 | -- reference to a bit packed array. |
ee6ba406 | 2053 | |
2054 | -- An indexed component or selected component whose prefix is a | |
0524b5dd | 2055 | -- reference to a bit packed array is itself a reference ot a |
2056 | -- bit packed array. | |
ee6ba406 | 2057 | |
2058 | -- The required transformation is | |
2059 | ||
2060 | -- Tnn : prefix_type := P; | |
2061 | -- Tnn.field := rhs; | |
2062 | -- P := Tnn; | |
2063 | ||
2064 | -- or | |
2065 | ||
2066 | -- Tnn : prefix_type := P; | |
2067 | -- Tnn (subscr) := rhs; | |
2068 | -- P := Tnn; | |
2069 | ||
2070 | -- Since P is going to be evaluated more than once, any subscripts | |
2071 | -- in P must have their evaluation forced. | |
2072 | ||
1627db8a | 2073 | if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component) |
ee6ba406 | 2074 | and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs)) |
2075 | then | |
2076 | declare | |
2077 | BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs)); | |
2078 | BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr); | |
2079 | Tnn : constant Entity_Id := | |
e0394eca | 2080 | Make_Temporary (Loc, 'T', BPAR_Expr); |
ee6ba406 | 2081 | |
2082 | begin | |
0524b5dd | 2083 | -- Insert the post assignment first, because we want to copy the |
2084 | -- BPAR_Expr tree before it gets analyzed in the context of the | |
2085 | -- pre assignment. Note that we do not analyze the post assignment | |
2086 | -- yet (we cannot till we have completed the analysis of the pre | |
2087 | -- assignment). As usual, the analysis of this post assignment | |
2088 | -- will happen on its own when we "run into" it after finishing | |
2089 | -- the current assignment. | |
ee6ba406 | 2090 | |
2091 | Insert_After (N, | |
2092 | Make_Assignment_Statement (Loc, | |
2093 | Name => New_Copy_Tree (BPAR_Expr), | |
2094 | Expression => New_Occurrence_Of (Tnn, Loc))); | |
2095 | ||
0524b5dd | 2096 | -- At this stage BPAR_Expr is a reference to a bit packed array |
2097 | -- where the reference was not expanded in the original tree, | |
2098 | -- since it was on the left side of an assignment. But in the | |
2099 | -- pre-assignment statement (the object definition), BPAR_Expr | |
7748ccb2 | 2100 | -- will end up on the right-hand side, and must be reexpanded. To |
0524b5dd | 2101 | -- achieve this, we reset the analyzed flag of all selected and |
2102 | -- indexed components down to the actual indexed component for | |
2103 | -- the packed array. | |
ee6ba406 | 2104 | |
2105 | Exp := BPAR_Expr; | |
2106 | loop | |
2107 | Set_Analyzed (Exp, False); | |
2108 | ||
72a98436 | 2109 | if Nkind_In (Exp, N_Indexed_Component, |
2110 | N_Selected_Component) | |
ee6ba406 | 2111 | then |
2112 | Exp := Prefix (Exp); | |
2113 | else | |
2114 | exit; | |
2115 | end if; | |
2116 | end loop; | |
2117 | ||
2866d595 | 2118 | -- Now we can insert and analyze the pre-assignment |
ee6ba406 | 2119 | |
2120 | -- If the right-hand side requires a transient scope, it has | |
2121 | -- already been placed on the stack. However, the declaration is | |
2122 | -- inserted in the tree outside of this scope, and must reflect | |
2123 | -- the proper scope for its variable. This awkward bit is forced | |
2124 | -- by the stricter scope discipline imposed by GCC 2.97. | |
2125 | ||
2126 | declare | |
2127 | Uses_Transient_Scope : constant Boolean := | |
4660e715 | 2128 | Scope_Is_Transient |
2129 | and then N = Node_To_Be_Wrapped; | |
ee6ba406 | 2130 | |
2131 | begin | |
2132 | if Uses_Transient_Scope then | |
0524b5dd | 2133 | Push_Scope (Scope (Current_Scope)); |
ee6ba406 | 2134 | end if; |
2135 | ||
2136 | Insert_Before_And_Analyze (N, | |
2137 | Make_Object_Declaration (Loc, | |
2138 | Defining_Identifier => Tnn, | |
2139 | Object_Definition => New_Occurrence_Of (BPAR_Typ, Loc), | |
2140 | Expression => BPAR_Expr)); | |
2141 | ||
2142 | if Uses_Transient_Scope then | |
2143 | Pop_Scope; | |
2144 | end if; | |
2145 | end; | |
2146 | ||
2147 | -- Now fix up the original assignment and continue processing | |
2148 | ||
2149 | Rewrite (Prefix (Lhs), | |
2150 | New_Occurrence_Of (Tnn, Loc)); | |
9dfe12ae | 2151 | |
2152 | -- We do not need to reanalyze that assignment, and we do not need | |
2153 | -- to worry about references to the temporary, but we do need to | |
2154 | -- make sure that the temporary is not marked as a true constant | |
39a0c1d3 | 2155 | -- since we now have a generated assignment to it. |
9dfe12ae | 2156 | |
2157 | Set_Is_True_Constant (Tnn, False); | |
ee6ba406 | 2158 | end; |
2159 | end if; | |
2160 | ||
236f09e1 | 2161 | -- When we have the appropriate type of aggregate in the expression (it |
2162 | -- has been determined during analysis of the aggregate by setting the | |
2163 | -- delay flag), let's perform in place assignment and thus avoid | |
2164 | -- creating a temporary. | |
ee6ba406 | 2165 | |
2166 | if Is_Delayed_Aggregate (Rhs) then | |
2167 | Convert_Aggr_In_Assignment (N); | |
2168 | Rewrite (N, Make_Null_Statement (Loc)); | |
2169 | Analyze (N); | |
f9e26ff7 | 2170 | |
ee6ba406 | 2171 | return; |
2172 | end if; | |
2173 | ||
0524b5dd | 2174 | -- Apply discriminant check if required. If Lhs is an access type to a |
17bfc2d6 | 2175 | -- designated type with discriminants, we must always check. If the |
2176 | -- type has unknown discriminants, more elaborate processing below. | |
ee6ba406 | 2177 | |
17bfc2d6 | 2178 | if Has_Discriminants (Etype (Lhs)) |
2179 | and then not Has_Unknown_Discriminants (Etype (Lhs)) | |
2180 | then | |
ee6ba406 | 2181 | -- Skip discriminant check if change of representation. Will be |
2182 | -- done when the change of representation is expanded out. | |
2183 | ||
41a3f747 | 2184 | if not Crep then |
ee6ba406 | 2185 | Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs); |
2186 | end if; | |
2187 | ||
2188 | -- If the type is private without discriminants, and the full type | |
2189 | -- has discriminants (necessarily with defaults) a check may still be | |
6819394e | 2190 | -- necessary if the Lhs is aliased. The private discriminants must be |
ee6ba406 | 2191 | -- visible to build the discriminant constraints. |
2192 | ||
9dfe12ae | 2193 | -- Only an explicit dereference that comes from source indicates |
2194 | -- aliasing. Access to formals of protected operations and entries | |
2195 | -- create dereferences but are not semantic aliasings. | |
2196 | ||
ee6ba406 | 2197 | elsif Is_Private_Type (Etype (Lhs)) |
4dcc60e5 | 2198 | and then Has_Discriminants (Typ) |
ee6ba406 | 2199 | and then Nkind (Lhs) = N_Explicit_Dereference |
9dfe12ae | 2200 | and then Comes_From_Source (Lhs) |
ee6ba406 | 2201 | then |
2202 | declare | |
6819394e | 2203 | Lt : constant Entity_Id := Etype (Lhs); |
2204 | Ubt : Entity_Id := Base_Type (Typ); | |
2205 | ||
ee6ba406 | 2206 | begin |
6819394e | 2207 | -- In the case of an expander-generated record subtype whose base |
2208 | -- type still appears private, Typ will have been set to that | |
2209 | -- private type rather than the underlying record type (because | |
2210 | -- Underlying type will have returned the record subtype), so it's | |
2211 | -- necessary to apply Underlying_Type again to the base type to | |
2212 | -- get the record type we need for the discriminant check. Such | |
2213 | -- subtypes can be created for assignments in certain cases, such | |
2214 | -- as within an instantiation passed this kind of private type. | |
2215 | -- It would be good to avoid this special test, but making changes | |
2216 | -- to prevent this odd form of record subtype seems difficult. ??? | |
2217 | ||
2218 | if Is_Private_Type (Ubt) then | |
2219 | Ubt := Underlying_Type (Ubt); | |
2220 | end if; | |
2221 | ||
2222 | Set_Etype (Lhs, Ubt); | |
2223 | Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs)); | |
2224 | Apply_Discriminant_Check (Rhs, Ubt, Lhs); | |
ee6ba406 | 2225 | Set_Etype (Lhs, Lt); |
2226 | end; | |
2227 | ||
8d11916f | 2228 | -- If the Lhs has a private type with unknown discriminants, it may |
2229 | -- have a full view with discriminants, but those are nameable only | |
2230 | -- in the underlying type, so convert the Rhs to it before potential | |
2231 | -- checking. Convert Lhs as well, otherwise the actual subtype might | |
9c20237a | 2232 | -- not be constructible. If the discriminants have defaults the type |
2233 | -- is unconstrained and there is nothing to check. | |
ee6ba406 | 2234 | |
2235 | elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs))) | |
2236 | and then Has_Discriminants (Typ) | |
9c20237a | 2237 | and then not Has_Defaulted_Discriminants (Typ) |
ee6ba406 | 2238 | then |
2239 | Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs)); | |
c4968aa2 | 2240 | Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs)); |
ee6ba406 | 2241 | Apply_Discriminant_Check (Rhs, Typ, Lhs); |
2242 | ||
0524b5dd | 2243 | -- In the access type case, we need the same discriminant check, and |
2244 | -- also range checks if we have an access to constrained array. | |
ee6ba406 | 2245 | |
2246 | elsif Is_Access_Type (Etype (Lhs)) | |
2247 | and then Is_Constrained (Designated_Type (Etype (Lhs))) | |
2248 | then | |
2249 | if Has_Discriminants (Designated_Type (Etype (Lhs))) then | |
2250 | ||
2251 | -- Skip discriminant check if change of representation. Will be | |
2252 | -- done when the change of representation is expanded out. | |
2253 | ||
41a3f747 | 2254 | if not Crep then |
ee6ba406 | 2255 | Apply_Discriminant_Check (Rhs, Etype (Lhs)); |
2256 | end if; | |
2257 | ||
2258 | elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then | |
2259 | Apply_Range_Check (Rhs, Etype (Lhs)); | |
2260 | ||
2261 | if Is_Constrained (Etype (Lhs)) then | |
2262 | Apply_Length_Check (Rhs, Etype (Lhs)); | |
2263 | end if; | |
2264 | ||
2265 | if Nkind (Rhs) = N_Allocator then | |
2266 | declare | |
2267 | Target_Typ : constant Entity_Id := Etype (Expression (Rhs)); | |
2268 | C_Es : Check_Result; | |
2269 | ||
2270 | begin | |
2271 | C_Es := | |
a2feb922 | 2272 | Get_Range_Checks |
ee6ba406 | 2273 | (Lhs, |
2274 | Target_Typ, | |
2275 | Etype (Designated_Type (Etype (Lhs)))); | |
2276 | ||
2277 | Insert_Range_Checks | |
2278 | (C_Es, | |
2279 | N, | |
2280 | Target_Typ, | |
2281 | Sloc (Lhs), | |
2282 | Lhs); | |
2283 | end; | |
2284 | end if; | |
2285 | end if; | |
2286 | ||
2287 | -- Apply range check for access type case | |
2288 | ||
2289 | elsif Is_Access_Type (Etype (Lhs)) | |
2290 | and then Nkind (Rhs) = N_Allocator | |
2291 | and then Nkind (Expression (Rhs)) = N_Qualified_Expression | |
2292 | then | |
2293 | Analyze_And_Resolve (Expression (Rhs)); | |
2294 | Apply_Range_Check | |
2295 | (Expression (Rhs), Designated_Type (Etype (Lhs))); | |
2296 | end if; | |
2297 | ||
4dcc60e5 | 2298 | -- Ada 2005 (AI-231): Generate the run-time check |
fa7497e8 | 2299 | |
2300 | if Is_Access_Type (Typ) | |
4dcc60e5 | 2301 | and then Can_Never_Be_Null (Etype (Lhs)) |
2302 | and then not Can_Never_Be_Null (Etype (Rhs)) | |
2c70d7c1 | 2303 | |
2304 | -- If an actual is an out parameter of a null-excluding access | |
2305 | -- type, there is access check on entry, so we set the flag | |
2306 | -- Suppress_Assignment_Checks on the generated statement to | |
2307 | -- assign the actual to the parameter block, and we do not want | |
2308 | -- to generate an additional check at this point. | |
2309 | ||
552cedee | 2310 | and then not Suppress_Assignment_Checks (N) |
fa7497e8 | 2311 | then |
4dcc60e5 | 2312 | Apply_Constraint_Check (Rhs, Etype (Lhs)); |
fa7497e8 | 2313 | end if; |
2314 | ||
1a9cc6cd | 2315 | -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a |
8b8be176 | 2316 | -- stand-alone obj of an anonymous access type. Do not install the check |
2317 | -- when the Lhs denotes a container cursor and the Next function employs | |
f9906591 | 2318 | -- an access type, because this can never result in a dangling pointer. |
47d210a3 | 2319 | |
2320 | if Is_Access_Type (Typ) | |
2321 | and then Is_Entity_Name (Lhs) | |
8b8be176 | 2322 | and then Ekind (Entity (Lhs)) /= E_Loop_Parameter |
de178ec5 | 2323 | and then Present (Effective_Extra_Accessibility (Entity (Lhs))) |
2324 | then | |
47d210a3 | 2325 | declare |
2326 | function Lhs_Entity return Entity_Id; | |
2327 | -- Look through renames to find the underlying entity. | |
2328 | -- For assignment to a rename, we don't care about the | |
2329 | -- Enclosing_Dynamic_Scope of the rename declaration. | |
2330 | ||
2331 | ---------------- | |
2332 | -- Lhs_Entity -- | |
2333 | ---------------- | |
2334 | ||
2335 | function Lhs_Entity return Entity_Id is | |
2336 | Result : Entity_Id := Entity (Lhs); | |
1a9cc6cd | 2337 | |
47d210a3 | 2338 | begin |
2339 | while Present (Renamed_Object (Result)) loop | |
1a9cc6cd | 2340 | |
47d210a3 | 2341 | -- Renamed_Object must return an Entity_Name here |
2342 | -- because of preceding "Present (E_E_A (...))" test. | |
2343 | ||
2344 | Result := Entity (Renamed_Object (Result)); | |
2345 | end loop; | |
1a9cc6cd | 2346 | |
47d210a3 | 2347 | return Result; |
2348 | end Lhs_Entity; | |
2349 | ||
1a9cc6cd | 2350 | -- Local Declarations |
2351 | ||
47d210a3 | 2352 | Access_Check : constant Node_Id := |
1a9cc6cd | 2353 | Make_Raise_Program_Error (Loc, |
2354 | Condition => | |
2355 | Make_Op_Gt (Loc, | |
2356 | Left_Opnd => | |
2357 | Dynamic_Accessibility_Level (Rhs), | |
2358 | Right_Opnd => | |
2359 | Make_Integer_Literal (Loc, | |
2360 | Intval => | |
2361 | Scope_Depth | |
2362 | (Enclosing_Dynamic_Scope | |
2363 | (Lhs_Entity)))), | |
2364 | Reason => PE_Accessibility_Check_Failed); | |
47d210a3 | 2365 | |
2366 | Access_Level_Update : constant Node_Id := | |
1a9cc6cd | 2367 | Make_Assignment_Statement (Loc, |
2368 | Name => | |
2369 | New_Occurrence_Of | |
2370 | (Effective_Extra_Accessibility | |
2371 | (Entity (Lhs)), Loc), | |
2372 | Expression => | |
2373 | Dynamic_Accessibility_Level (Rhs)); | |
2374 | ||
47d210a3 | 2375 | begin |
2376 | if not Accessibility_Checks_Suppressed (Entity (Lhs)) then | |
2377 | Insert_Action (N, Access_Check); | |
2378 | end if; | |
1a9cc6cd | 2379 | |
47d210a3 | 2380 | Insert_Action (N, Access_Level_Update); |
2381 | end; | |
2382 | end if; | |
2383 | ||
41a3f747 | 2384 | -- Case of assignment to a bit packed array element. If there is a |
2385 | -- change of representation this must be expanded into components, | |
2386 | -- otherwise this is a bit-field assignment. | |
ee6ba406 | 2387 | |
2388 | if Nkind (Lhs) = N_Indexed_Component | |
2389 | and then Is_Bit_Packed_Array (Etype (Prefix (Lhs))) | |
2390 | then | |
3580dc54 | 2391 | -- Normal case, no change of representation |
2392 | ||
20486e0b | 2393 | if not Crep then |
2394 | Expand_Bit_Packed_Element_Set (N); | |
2395 | return; | |
20486e0b | 2396 | |
3580dc54 | 2397 | -- Change of representation case |
2398 | ||
2399 | else | |
20486e0b | 2400 | -- Generate the following, to force component-by-component |
2401 | -- assignments in an efficient way. Otherwise each component | |
2402 | -- will require a temporary and two bit-field manipulations. | |
2403 | ||
2404 | -- T1 : Elmt_Type; | |
2405 | -- T1 := RhS; | |
2406 | -- Lhs := T1; | |
2407 | ||
2408 | declare | |
2409 | Tnn : constant Entity_Id := Make_Temporary (Loc, 'T'); | |
2410 | Stats : List_Id; | |
2411 | ||
2412 | begin | |
3580dc54 | 2413 | Stats := |
2414 | New_List ( | |
2415 | Make_Object_Declaration (Loc, | |
2416 | Defining_Identifier => Tnn, | |
2417 | Object_Definition => | |
2418 | New_Occurrence_Of (Etype (Lhs), Loc)), | |
2419 | Make_Assignment_Statement (Loc, | |
2420 | Name => New_Occurrence_Of (Tnn, Loc), | |
2421 | Expression => Relocate_Node (Rhs)), | |
2422 | Make_Assignment_Statement (Loc, | |
2423 | Name => Relocate_Node (Lhs), | |
2424 | Expression => New_Occurrence_Of (Tnn, Loc))); | |
20486e0b | 2425 | |
2426 | Insert_Actions (N, Stats); | |
2427 | Rewrite (N, Make_Null_Statement (Loc)); | |
2428 | Analyze (N); | |
2429 | end; | |
2430 | end if; | |
ee6ba406 | 2431 | |
cd24e497 | 2432 | -- Build-in-place function call case. This is for assignment statements |
2433 | -- that come from aggregate component associations or from init procs. | |
2434 | -- User-written assignment statements with b-i-p calls are handled | |
2435 | -- elsewhere. | |
0326143c | 2436 | |
cd24e497 | 2437 | elsif Is_Build_In_Place_Function_Call (Rhs) then |
2438 | pragma Assert (not Comes_From_Source (N)); | |
0326143c | 2439 | Make_Build_In_Place_Call_In_Assignment (N, Rhs); |
2440 | ||
ee6ba406 | 2441 | elsif Is_Tagged_Type (Typ) |
45851103 | 2442 | or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ)) |
ee6ba406 | 2443 | then |
2444 | Tagged_Case : declare | |
2445 | L : List_Id := No_List; | |
2446 | Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N); | |
2447 | ||
2448 | begin | |
d2b860b4 | 2449 | -- In the controlled case, we ensure that function calls are |
2450 | -- evaluated before finalizing the target. In all cases, it makes | |
7748ccb2 | 2451 | -- the expansion easier if the side effects are removed first. |
ee6ba406 | 2452 | |
2453 | Remove_Side_Effects (Lhs); | |
2454 | Remove_Side_Effects (Rhs); | |
2455 | ||
2456 | -- Avoid recursion in the mechanism | |
2457 | ||
2458 | Set_Analyzed (N); | |
2459 | ||
2460 | -- If dispatching assignment, we need to dispatch to _assign | |
2461 | ||
2462 | if Is_Class_Wide_Type (Typ) | |
2463 | ||
4660e715 | 2464 | -- If the type is tagged, we may as well use the predefined |
2465 | -- primitive assignment. This avoids inlining a lot of code | |
bdf265a3 | 2466 | -- and in the class-wide case, the assignment is replaced |
2467 | -- by a dispatching call to _assign. It is suppressed in the | |
2468 | -- case of assignments created by the expander that correspond | |
2469 | -- to initializations, where we do want to copy the tag | |
2010430f | 2470 | -- (Expand_Ctrl_Actions flag is set False in this case). It is |
bdf265a3 | 2471 | -- also suppressed if restriction No_Dispatching_Calls is in |
2472 | -- force because in that case predefined primitives are not | |
278c67dc | 2473 | -- generated. |
4660e715 | 2474 | |
2475 | or else (Is_Tagged_Type (Typ) | |
d2b860b4 | 2476 | and then Chars (Current_Scope) /= Name_uAssign |
2477 | and then Expand_Ctrl_Actions | |
5236d9f4 | 2478 | and then |
2479 | not Restriction_Active (No_Dispatching_Calls)) | |
ee6ba406 | 2480 | then |
4e104ca3 | 2481 | if Is_Limited_Type (Typ) then |
2482 | ||
2483 | -- This can happen in an instance when the formal is an | |
2484 | -- extension of a limited interface, and the actual is | |
2485 | -- limited. This is an error according to AI05-0087, but | |
2486 | -- is not caught at the point of instantiation in earlier | |
f6811146 | 2487 | -- versions. We also must verify that the limited type does |
2488 | -- not come from source as corner cases may exist where | |
2489 | -- an assignment was not intended like the pathological case | |
2490 | -- of a raise expression within a return statement. | |
4e104ca3 | 2491 | |
a58d632f | 2492 | -- This is wrong, error messages cannot be issued during |
2493 | -- expansion, since they would be missed in -gnatc mode ??? | |
2494 | ||
f6811146 | 2495 | if Comes_From_Source (N) then |
2496 | Error_Msg_N | |
2497 | ("assignment not available on limited type", N); | |
2498 | end if; | |
2499 | ||
4e104ca3 | 2500 | return; |
2501 | end if; | |
2502 | ||
0524b5dd | 2503 | -- Fetch the primitive op _assign and proper type to call it. |
d2b860b4 | 2504 | -- Because of possible conflicts between private and full view, |
2505 | -- fetch the proper type directly from the operation profile. | |
ee6ba406 | 2506 | |
2507 | declare | |
9dfe12ae | 2508 | Op : constant Entity_Id := |
2509 | Find_Prim_Op (Typ, Name_uAssign); | |
ee6ba406 | 2510 | F_Typ : Entity_Id := Etype (First_Formal (Op)); |
2511 | ||
2512 | begin | |
2513 | -- If the assignment is dispatching, make sure to use the | |
81f0d4b1 | 2514 | -- proper type. |
ee6ba406 | 2515 | |
2516 | if Is_Class_Wide_Type (Typ) then | |
2517 | F_Typ := Class_Wide_Type (F_Typ); | |
2518 | end if; | |
2519 | ||
81f0d4b1 | 2520 | L := New_List; |
2521 | ||
2522 | -- In case of assignment to a class-wide tagged type, before | |
2523 | -- the assignment we generate run-time check to ensure that | |
21ec6442 | 2524 | -- the tags of source and target match. |
81f0d4b1 | 2525 | |
d7ec9a29 | 2526 | if not Tag_Checks_Suppressed (Typ) |
2527 | and then Is_Class_Wide_Type (Typ) | |
81f0d4b1 | 2528 | and then Is_Tagged_Type (Typ) |
2529 | and then Is_Tagged_Type (Underlying_Type (Etype (Rhs))) | |
2530 | then | |
3a2486a4 | 2531 | declare |
2532 | Lhs_Tag : Node_Id; | |
2533 | Rhs_Tag : Node_Id; | |
2534 | ||
2535 | begin | |
2536 | if not Is_Interface (Typ) then | |
2537 | Lhs_Tag := | |
2538 | Make_Selected_Component (Loc, | |
2539 | Prefix => Duplicate_Subexpr (Lhs), | |
2540 | Selector_Name => | |
2541 | Make_Identifier (Loc, Name_uTag)); | |
2542 | Rhs_Tag := | |
2543 | Make_Selected_Component (Loc, | |
2544 | Prefix => Duplicate_Subexpr (Rhs), | |
2545 | Selector_Name => | |
2546 | Make_Identifier (Loc, Name_uTag)); | |
2547 | else | |
2548 | -- Displace the pointer to the base of the objects | |
2549 | -- applying 'Address, which is later expanded into | |
2550 | -- a call to RE_Base_Address. | |
2551 | ||
2552 | Lhs_Tag := | |
2553 | Make_Explicit_Dereference (Loc, | |
2554 | Prefix => | |
2555 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
2556 | Make_Attribute_Reference (Loc, | |
7f5dd8d8 | 2557 | Prefix => Duplicate_Subexpr (Lhs), |
3a2486a4 | 2558 | Attribute_Name => Name_Address))); |
2559 | Rhs_Tag := | |
2560 | Make_Explicit_Dereference (Loc, | |
2561 | Prefix => | |
2562 | Unchecked_Convert_To (RTE (RE_Tag_Ptr), | |
2563 | Make_Attribute_Reference (Loc, | |
7f5dd8d8 | 2564 | Prefix => Duplicate_Subexpr (Rhs), |
3a2486a4 | 2565 | Attribute_Name => Name_Address))); |
2566 | end if; | |
2567 | ||
2568 | Append_To (L, | |
2569 | Make_Raise_Constraint_Error (Loc, | |
2570 | Condition => | |
2571 | Make_Op_Ne (Loc, | |
7f5dd8d8 | 2572 | Left_Opnd => Lhs_Tag, |
3a2486a4 | 2573 | Right_Opnd => Rhs_Tag), |
7f5dd8d8 | 2574 | Reason => CE_Tag_Check_Failed)); |
3a2486a4 | 2575 | end; |
81f0d4b1 | 2576 | end if; |
2577 | ||
f235fede | 2578 | declare |
2579 | Left_N : Node_Id := Duplicate_Subexpr (Lhs); | |
2580 | Right_N : Node_Id := Duplicate_Subexpr (Rhs); | |
2581 | ||
2582 | begin | |
2583 | -- In order to dispatch the call to _assign the type of | |
2584 | -- the actuals must match. Add conversion (if required). | |
2585 | ||
2586 | if Etype (Lhs) /= F_Typ then | |
2587 | Left_N := Unchecked_Convert_To (F_Typ, Left_N); | |
2588 | end if; | |
2589 | ||
2590 | if Etype (Rhs) /= F_Typ then | |
2591 | Right_N := Unchecked_Convert_To (F_Typ, Right_N); | |
2592 | end if; | |
2593 | ||
2594 | Append_To (L, | |
2595 | Make_Procedure_Call_Statement (Loc, | |
83c6c069 | 2596 | Name => New_Occurrence_Of (Op, Loc), |
f235fede | 2597 | Parameter_Associations => New_List ( |
2598 | Node1 => Left_N, | |
2599 | Node2 => Right_N))); | |
2600 | end; | |
ee6ba406 | 2601 | end; |
2602 | ||
2603 | else | |
2604 | L := Make_Tag_Ctrl_Assignment (N); | |
2605 | ||
0524b5dd | 2606 | -- We can't afford to have destructive Finalization Actions in |
2607 | -- the Self assignment case, so if the target and the source | |
2608 | -- are not obviously different, code is generated to avoid the | |
2609 | -- self assignment case: | |
21ec6442 | 2610 | |
ee6ba406 | 2611 | -- if lhs'address /= rhs'address then |
2612 | -- <code for controlled and/or tagged assignment> | |
2613 | -- end if; | |
2614 | ||
4ef96261 | 2615 | -- Skip this if Restriction (No_Finalization) is active |
2616 | ||
ee6ba406 | 2617 | if not Statically_Different (Lhs, Rhs) |
2618 | and then Expand_Ctrl_Actions | |
4ef96261 | 2619 | and then not Restriction_Active (No_Finalization) |
ee6ba406 | 2620 | then |
2621 | L := New_List ( | |
2622 | Make_Implicit_If_Statement (N, | |
2623 | Condition => | |
2624 | Make_Op_Ne (Loc, | |
2625 | Left_Opnd => | |
2626 | Make_Attribute_Reference (Loc, | |
2627 | Prefix => Duplicate_Subexpr (Lhs), | |
2628 | Attribute_Name => Name_Address), | |
2629 | ||
2630 | Right_Opnd => | |
2631 | Make_Attribute_Reference (Loc, | |
2632 | Prefix => Duplicate_Subexpr (Rhs), | |
2633 | Attribute_Name => Name_Address)), | |
2634 | ||
2635 | Then_Statements => L)); | |
2636 | end if; | |
2637 | ||
2638 | -- We need to set up an exception handler for implementing | |
0524b5dd | 2639 | -- 7.6.1(18). The remaining adjustments are tackled by the |
ee6ba406 | 2640 | -- implementation of adjust for record_controllers (see |
21ec6442 | 2641 | -- s-finimp.adb). |
ee6ba406 | 2642 | |
9dfe12ae | 2643 | -- This is skipped if we have no finalization |
ee6ba406 | 2644 | |
9dfe12ae | 2645 | if Expand_Ctrl_Actions |
1e16c51c | 2646 | and then not Restriction_Active (No_Finalization) |
9dfe12ae | 2647 | then |
ee6ba406 | 2648 | L := New_List ( |
2649 | Make_Block_Statement (Loc, | |
2650 | Handled_Statement_Sequence => | |
2651 | Make_Handled_Sequence_Of_Statements (Loc, | |
2652 | Statements => L, | |
2653 | Exception_Handlers => New_List ( | |
0524b5dd | 2654 | Make_Handler_For_Ctrl_Operation (Loc))))); |
ee6ba406 | 2655 | end if; |
2656 | end if; | |
2657 | ||
2658 | Rewrite (N, | |
2659 | Make_Block_Statement (Loc, | |
2660 | Handled_Statement_Sequence => | |
2661 | Make_Handled_Sequence_Of_Statements (Loc, Statements => L))); | |
2662 | ||
36b938a3 | 2663 | -- If no restrictions on aborts, protect the whole assignment |
21ec6442 | 2664 | -- for controlled objects as per 9.8(11). |
ee6ba406 | 2665 | |
45851103 | 2666 | if Needs_Finalization (Typ) |
ee6ba406 | 2667 | and then Expand_Ctrl_Actions |
2668 | and then Abort_Allowed | |
2669 | then | |
2670 | declare | |
2671 | Blk : constant Entity_Id := | |
4660e715 | 2672 | New_Internal_Entity |
2673 | (E_Block, Current_Scope, Sloc (N), 'B'); | |
32d2c8a5 | 2674 | AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); |
ee6ba406 | 2675 | |
2676 | begin | |
3d42f149 | 2677 | Set_Is_Abort_Block (N); |
2678 | ||
ee6ba406 | 2679 | Set_Scope (Blk, Current_Scope); |
2680 | Set_Etype (Blk, Standard_Void_Type); | |
2681 | Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); | |
2682 | ||
2683 | Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); | |
2684 | Set_At_End_Proc (Handled_Statement_Sequence (N), | |
32d2c8a5 | 2685 | New_Occurrence_Of (AUD, Loc)); |
2686 | ||
2687 | -- Present the Abort_Undefer_Direct function to the backend | |
2688 | -- so that it can inline the call to the function. | |
2689 | ||
2690 | Add_Inlined_Body (AUD, N); | |
2691 | ||
ee6ba406 | 2692 | Expand_At_End_Handler |
2693 | (Handled_Statement_Sequence (N), Blk); | |
2694 | end; | |
2695 | end if; | |
2696 | ||
3afcdce0 | 2697 | -- N has been rewritten to a block statement for which it is |
2698 | -- known by construction that no checks are necessary: analyze | |
2699 | -- it with all checks suppressed. | |
2700 | ||
2701 | Analyze (N, Suppress => All_Checks); | |
ee6ba406 | 2702 | return; |
2703 | end Tagged_Case; | |
2704 | ||
2705 | -- Array types | |
2706 | ||
2707 | elsif Is_Array_Type (Typ) then | |
2708 | declare | |
2709 | Actual_Rhs : Node_Id := Rhs; | |
2710 | ||
2711 | begin | |
1627db8a | 2712 | while Nkind_In (Actual_Rhs, N_Type_Conversion, |
2713 | N_Qualified_Expression) | |
ee6ba406 | 2714 | loop |
2715 | Actual_Rhs := Expression (Actual_Rhs); | |
2716 | end loop; | |
2717 | ||
2718 | Expand_Assign_Array (N, Actual_Rhs); | |
2719 | return; | |
2720 | end; | |
2721 | ||
2722 | -- Record types | |
2723 | ||
2724 | elsif Is_Record_Type (Typ) then | |
2725 | Expand_Assign_Record (N); | |
2726 | return; | |
2727 | ||
0524b5dd | 2728 | -- Scalar types. This is where we perform the processing related to the |
2729 | -- requirements of (RM 13.9.1(9-11)) concerning the handling of invalid | |
2730 | -- scalar values. | |
ee6ba406 | 2731 | |
2732 | elsif Is_Scalar_Type (Typ) then | |
2733 | ||
2734 | -- Case where right side is known valid | |
2735 | ||
2736 | if Expr_Known_Valid (Rhs) then | |
2737 | ||
0524b5dd | 2738 | -- Here the right side is valid, so it is fine. The case to deal |
2739 | -- with is when the left side is a local variable reference whose | |
2740 | -- value is not currently known to be valid. If this is the case, | |
9af28f61 | 2741 | -- and the assignment appears in an unconditional context, then |
2742 | -- we can mark the left side as now being valid if one of these | |
2743 | -- conditions holds: | |
2744 | ||
2745 | -- The expression of the right side has Do_Range_Check set so | |
2746 | -- that we know a range check will be performed. Note that it | |
2747 | -- can be the case that a range check is omitted because we | |
2748 | -- make the assumption that we can assume validity for operands | |
2749 | -- appearing in the right side in determining whether a range | |
2750 | -- check is required | |
2751 | ||
2752 | -- The subtype of the right side matches the subtype of the | |
2753 | -- left side. In this case, even though we have not checked | |
2754 | -- the range of the right side, we know it is in range of its | |
2755 | -- subtype if the expression is valid. | |
ee6ba406 | 2756 | |
2757 | if Is_Local_Variable_Reference (Lhs) | |
2758 | and then not Is_Known_Valid (Entity (Lhs)) | |
2759 | and then In_Unconditional_Context (N) | |
2760 | then | |
9af28f61 | 2761 | if Do_Range_Check (Rhs) |
2762 | or else Etype (Lhs) = Etype (Rhs) | |
2763 | then | |
2764 | Set_Is_Known_Valid (Entity (Lhs), True); | |
2765 | end if; | |
ee6ba406 | 2766 | end if; |
2767 | ||
2768 | -- Case where right side may be invalid in the sense of the RM | |
0524b5dd | 2769 | -- reference above. The RM does not require that we check for the |
2770 | -- validity on an assignment, but it does require that the assignment | |
2771 | -- of an invalid value not cause erroneous behavior. | |
ee6ba406 | 2772 | |
2773 | -- The general approach in GNAT is to use the Is_Known_Valid flag | |
2774 | -- to avoid the need for validity checking on assignments. However | |
2775 | -- in some cases, we have to do validity checking in order to make | |
2776 | -- sure that the setting of this flag is correct. | |
2777 | ||
2778 | else | |
2779 | -- Validate right side if we are validating copies | |
2780 | ||
2781 | if Validity_Checks_On | |
0326143c | 2782 | and then Validity_Check_Copies |
ee6ba406 | 2783 | then |
7748ccb2 | 2784 | -- Skip this if left-hand side is an array or record component |
0326143c | 2785 | -- and elementary component validity checks are suppressed. |
2786 | ||
1627db8a | 2787 | if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component) |
0326143c | 2788 | and then not Validity_Check_Components |
2789 | then | |
2790 | null; | |
2791 | else | |
2792 | Ensure_Valid (Rhs); | |
2793 | end if; | |
ee6ba406 | 2794 | |
2795 | -- We can propagate this to the left side where appropriate | |
2796 | ||
2797 | if Is_Local_Variable_Reference (Lhs) | |
2798 | and then not Is_Known_Valid (Entity (Lhs)) | |
2799 | and then In_Unconditional_Context (N) | |
2800 | then | |
2801 | Set_Is_Known_Valid (Entity (Lhs), True); | |
2802 | end if; | |
2803 | ||
2804 | -- Otherwise check to see what should be done | |
2805 | ||
0524b5dd | 2806 | -- If left side is a local variable, then we just set its flag to |
2807 | -- indicate that its value may no longer be valid, since we are | |
2808 | -- copying a potentially invalid value. | |
ee6ba406 | 2809 | |
2810 | elsif Is_Local_Variable_Reference (Lhs) then | |
2811 | Set_Is_Known_Valid (Entity (Lhs), False); | |
2812 | ||
0524b5dd | 2813 | -- Check for case of a nonlocal variable on the left side which |
2814 | -- is currently known to be valid. In this case, we simply ensure | |
2815 | -- that the right side is valid. We only play the game of copying | |
2816 | -- validity status for local variables, since we are doing this | |
2817 | -- statically, not by tracing the full flow graph. | |
ee6ba406 | 2818 | |
2819 | elsif Is_Entity_Name (Lhs) | |
2820 | and then Is_Known_Valid (Entity (Lhs)) | |
2821 | then | |
236f09e1 | 2822 | -- Note: If Validity_Checking mode is set to none, we ignore |
2823 | -- the Ensure_Valid call so don't worry about that case here. | |
ee6ba406 | 2824 | |
2825 | Ensure_Valid (Rhs); | |
2826 | ||
0524b5dd | 2827 | -- In all other cases, we can safely copy an invalid value without |
2828 | -- worrying about the status of the left side. Since it is not a | |
2829 | -- variable reference it will not be considered | |
ee6ba406 | 2830 | -- as being known to be valid in any case. |
2831 | ||
2832 | else | |
2833 | null; | |
2834 | end if; | |
2835 | end if; | |
2836 | end if; | |
2837 | ||
9dfe12ae | 2838 | exception |
2839 | when RE_Not_Available => | |
2840 | return; | |
ee6ba406 | 2841 | end Expand_N_Assignment_Statement; |
2842 | ||
2843 | ------------------------------ | |
2844 | -- Expand_N_Block_Statement -- | |
2845 | ------------------------------ | |
2846 | ||
2847 | -- Encode entity names defined in block statement | |
2848 | ||
2849 | procedure Expand_N_Block_Statement (N : Node_Id) is | |
2850 | begin | |
2851 | Qualify_Entity_Names (N); | |
2852 | end Expand_N_Block_Statement; | |
2853 | ||
2854 | ----------------------------- | |
2855 | -- Expand_N_Case_Statement -- | |
2856 | ----------------------------- | |
2857 | ||
2858 | procedure Expand_N_Case_Statement (N : Node_Id) is | |
9dfe12ae | 2859 | Loc : constant Source_Ptr := Sloc (N); |
2860 | Expr : constant Node_Id := Expression (N); | |
2861 | Alt : Node_Id; | |
2862 | Len : Nat; | |
2863 | Cond : Node_Id; | |
2864 | Choice : Node_Id; | |
2865 | Chlist : List_Id; | |
ee6ba406 | 2866 | |
2867 | begin | |
0524b5dd | 2868 | -- Check for the situation where we know at compile time which branch |
3c9ef629 | 2869 | -- will be taken. |
ee6ba406 | 2870 | |
3c9ef629 | 2871 | -- If the value is static but its subtype is predicated and the value |
2872 | -- does not obey the predicate, the value is marked non-static, and | |
0c978552 | 2873 | -- there can be no corresponding static alternative. In that case we |
2874 | -- replace the case statement with an exception, regardless of whether | |
2c011bc5 | 2875 | -- assertions are enabled or not, unless predicates are ignored. |
3c9ef629 | 2876 | |
2877 | if Compile_Time_Known_Value (Expr) | |
0c978552 | 2878 | and then Has_Predicates (Etype (Expr)) |
2c011bc5 | 2879 | and then not Predicates_Ignored (Etype (Expr)) |
0c978552 | 2880 | and then not Is_OK_Static_Expression (Expr) |
2881 | then | |
2882 | Rewrite (N, | |
2883 | Make_Raise_Constraint_Error (Loc, Reason => CE_Invalid_Data)); | |
2884 | Analyze (N); | |
2885 | return; | |
2886 | ||
2887 | elsif Compile_Time_Known_Value (Expr) | |
3c9ef629 | 2888 | and then (not Has_Predicates (Etype (Expr)) |
2889 | or else Is_Static_Expression (Expr)) | |
2890 | then | |
9dfe12ae | 2891 | Alt := Find_Static_Alternative (N); |
ee6ba406 | 2892 | |
cf580b1d | 2893 | -- Do not consider controlled objects found in a case statement which |
2894 | -- actually models a case expression because their early finalization | |
2895 | -- will affect the result of the expression. | |
2896 | ||
2897 | if not From_Conditional_Expression (N) then | |
2898 | Process_Statements_For_Controlled_Objects (Alt); | |
2899 | end if; | |
f239f5be | 2900 | |
0524b5dd | 2901 | -- Move statements from this alternative after the case statement. |
2902 | -- They are already analyzed, so will be skipped by the analyzer. | |
ee6ba406 | 2903 | |
9dfe12ae | 2904 | Insert_List_After (N, Statements (Alt)); |
ee6ba406 | 2905 | |
0326143c | 2906 | -- That leaves the case statement as a shell. So now we can kill all |
2907 | -- other alternatives in the case statement. | |
ee6ba406 | 2908 | |
9dfe12ae | 2909 | Kill_Dead_Code (Expression (N)); |
0326143c | 2910 | |
2911 | declare | |
f239f5be | 2912 | Dead_Alt : Node_Id; |
0326143c | 2913 | |
2914 | begin | |
2915 | -- Loop through case alternatives, skipping pragmas, and skipping | |
2916 | -- the one alternative that we select (and therefore retain). | |
2917 | ||
f239f5be | 2918 | Dead_Alt := First (Alternatives (N)); |
2919 | while Present (Dead_Alt) loop | |
2920 | if Dead_Alt /= Alt | |
2921 | and then Nkind (Dead_Alt) = N_Case_Statement_Alternative | |
0326143c | 2922 | then |
f239f5be | 2923 | Kill_Dead_Code (Statements (Dead_Alt), Warn_On_Deleted_Code); |
0326143c | 2924 | end if; |
2925 | ||
f239f5be | 2926 | Next (Dead_Alt); |
0326143c | 2927 | end loop; |
2928 | end; | |
2929 | ||
9dfe12ae | 2930 | Rewrite (N, Make_Null_Statement (Loc)); |
2931 | return; | |
2932 | end if; | |
ee6ba406 | 2933 | |
9dfe12ae | 2934 | -- Here if the choice is not determined at compile time |
ee6ba406 | 2935 | |
9dfe12ae | 2936 | declare |
2937 | Last_Alt : constant Node_Id := Last (Alternatives (N)); | |
ee6ba406 | 2938 | |
9dfe12ae | 2939 | Others_Present : Boolean; |
2940 | Others_Node : Node_Id; | |
ee6ba406 | 2941 | |
9dfe12ae | 2942 | Then_Stms : List_Id; |
2943 | Else_Stms : List_Id; | |
ee6ba406 | 2944 | |
9dfe12ae | 2945 | begin |
2946 | if Nkind (First (Discrete_Choices (Last_Alt))) = N_Others_Choice then | |
2947 | Others_Present := True; | |
2948 | Others_Node := Last_Alt; | |
2949 | else | |
2950 | Others_Present := False; | |
2951 | end if; | |
ee6ba406 | 2952 | |
9dfe12ae | 2953 | -- First step is to worry about possible invalid argument. The RM |
2954 | -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is | |
2955 | -- outside the base range), then Constraint_Error must be raised. | |
ee6ba406 | 2956 | |
9dfe12ae | 2957 | -- Case of validity check required (validity checks are on, the |
2958 | -- expression is not known to be valid, and the case statement | |
2959 | -- comes from source -- no need to validity check internally | |
2960 | -- generated case statements). | |
ee6ba406 | 2961 | |
2c011bc5 | 2962 | if Validity_Check_Default |
2963 | and then not Predicates_Ignored (Etype (Expr)) | |
2964 | then | |
9dfe12ae | 2965 | Ensure_Valid (Expr); |
2966 | end if; | |
ee6ba406 | 2967 | |
0524b5dd | 2968 | -- If there is only a single alternative, just replace it with the |
2969 | -- sequence of statements since obviously that is what is going to | |
2970 | -- be executed in all cases. | |
ee6ba406 | 2971 | |
9dfe12ae | 2972 | Len := List_Length (Alternatives (N)); |
ee6ba406 | 2973 | |
9dfe12ae | 2974 | if Len = 1 then |
f239f5be | 2975 | |
2976 | -- We still need to evaluate the expression if it has any side | |
2977 | -- effects. | |
ee6ba406 | 2978 | |
9dfe12ae | 2979 | Remove_Side_Effects (Expression (N)); |
f239f5be | 2980 | Alt := First (Alternatives (N)); |
2981 | ||
cf580b1d | 2982 | -- Do not consider controlled objects found in a case statement |
2983 | -- which actually models a case expression because their early | |
2984 | -- finalization will affect the result of the expression. | |
2985 | ||
2986 | if not From_Conditional_Expression (N) then | |
2987 | Process_Statements_For_Controlled_Objects (Alt); | |
2988 | end if; | |
2989 | ||
f239f5be | 2990 | Insert_List_After (N, Statements (Alt)); |
ee6ba406 | 2991 | |
0524b5dd | 2992 | -- That leaves the case statement as a shell. The alternative that |
2993 | -- will be executed is reset to a null list. So now we can kill | |
2994 | -- the entire case statement. | |
ee6ba406 | 2995 | |
2996 | Kill_Dead_Code (Expression (N)); | |
ee6ba406 | 2997 | Rewrite (N, Make_Null_Statement (Loc)); |
9dfe12ae | 2998 | return; |
ee6ba406 | 2999 | |
9dfe12ae | 3000 | -- An optimization. If there are only two alternatives, and only |
3001 | -- a single choice, then rewrite the whole case statement as an | |
36b938a3 | 3002 | -- if statement, since this can result in subsequent optimizations. |
9dfe12ae | 3003 | -- This helps not only with case statements in the source of a |
3004 | -- simple form, but also with generated code (discriminant check | |
f65f7fdf | 3005 | -- functions in particular). |
3006 | ||
3007 | -- Note: it is OK to do this before expanding out choices for any | |
3008 | -- static predicates, since the if statement processing will handle | |
3009 | -- the static predicate case fine. | |
ee6ba406 | 3010 | |
f239f5be | 3011 | elsif Len = 2 then |
9dfe12ae | 3012 | Chlist := Discrete_Choices (First (Alternatives (N))); |
ee6ba406 | 3013 | |
9dfe12ae | 3014 | if List_Length (Chlist) = 1 then |
3015 | Choice := First (Chlist); | |
ee6ba406 | 3016 | |
9dfe12ae | 3017 | Then_Stms := Statements (First (Alternatives (N))); |
3018 | Else_Stms := Statements (Last (Alternatives (N))); | |
ee6ba406 | 3019 | |
9dfe12ae | 3020 | -- For TRUE, generate "expression", not expression = true |
ee6ba406 | 3021 | |
9dfe12ae | 3022 | if Nkind (Choice) = N_Identifier |
3023 | and then Entity (Choice) = Standard_True | |
3024 | then | |
3025 | Cond := Expression (N); | |
3026 | ||
3027 | -- For FALSE, generate "expression" and switch then/else | |
3028 | ||
3029 | elsif Nkind (Choice) = N_Identifier | |
3030 | and then Entity (Choice) = Standard_False | |
3031 | then | |
3032 | Cond := Expression (N); | |
3033 | Else_Stms := Statements (First (Alternatives (N))); | |
3034 | Then_Stms := Statements (Last (Alternatives (N))); | |
3035 | ||
3036 | -- For a range, generate "expression in range" | |
3037 | ||
3038 | elsif Nkind (Choice) = N_Range | |
3039 | or else (Nkind (Choice) = N_Attribute_Reference | |
3040 | and then Attribute_Name (Choice) = Name_Range) | |
3041 | or else (Is_Entity_Name (Choice) | |
3042 | and then Is_Type (Entity (Choice))) | |
9dfe12ae | 3043 | then |
3044 | Cond := | |
3045 | Make_In (Loc, | |
3046 | Left_Opnd => Expression (N), | |
3047 | Right_Opnd => Relocate_Node (Choice)); | |
3048 | ||
ba33856e | 3049 | -- A subtype indication is not a legal operator in a membership |
3050 | -- test, so retrieve its range. | |
3051 | ||
3052 | elsif Nkind (Choice) = N_Subtype_Indication then | |
3053 | Cond := | |
3054 | Make_In (Loc, | |
3055 | Left_Opnd => Expression (N), | |
3056 | Right_Opnd => | |
3057 | Relocate_Node | |
3058 | (Range_Expression (Constraint (Choice)))); | |
3059 | ||
9dfe12ae | 3060 | -- For any other subexpression "expression = value" |
3061 | ||
3062 | else | |
3063 | Cond := | |
3064 | Make_Op_Eq (Loc, | |
3065 | Left_Opnd => Expression (N), | |
3066 | Right_Opnd => Relocate_Node (Choice)); | |
3067 | end if; | |
3068 | ||
3069 | -- Now rewrite the case as an IF | |
3070 | ||
3071 | Rewrite (N, | |
3072 | Make_If_Statement (Loc, | |
3073 | Condition => Cond, | |
3074 | Then_Statements => Then_Stms, | |
3075 | Else_Statements => Else_Stms)); | |
3076 | Analyze (N); | |
3077 | return; | |
ee6ba406 | 3078 | end if; |
9dfe12ae | 3079 | end if; |
3080 | ||
0524b5dd | 3081 | -- If the last alternative is not an Others choice, replace it with |
3082 | -- an N_Others_Choice. Note that we do not bother to call Analyze on | |
3083 | -- the modified case statement, since it's only effect would be to | |
3084 | -- compute the contents of the Others_Discrete_Choices which is not | |
3085 | -- needed by the back end anyway. | |
9dfe12ae | 3086 | |
ba33856e | 3087 | -- The reason for this is that the back end always needs some default |
3088 | -- for a switch, so if we have not supplied one in the processing | |
3089 | -- above for validity checking, then we need to supply one here. | |
9dfe12ae | 3090 | |
3091 | if not Others_Present then | |
3092 | Others_Node := Make_Others_Choice (Sloc (Last_Alt)); | |
2c011bc5 | 3093 | |
3094 | -- If Predicates_Ignored is true the value does not satisfy the | |
3095 | -- predicate, and there is no Others choice, Constraint_Error | |
3096 | -- must be raised (4.5.7 (21/3)). | |
3097 | ||
3098 | if Predicates_Ignored (Etype (Expr)) then | |
3099 | declare | |
b98d0bd6 | 3100 | Except : constant Node_Id := |
3101 | Make_Raise_Constraint_Error (Loc, | |
3102 | Reason => CE_Invalid_Data); | |
2c011bc5 | 3103 | New_Alt : constant Node_Id := |
b98d0bd6 | 3104 | Make_Case_Statement_Alternative (Loc, |
3105 | Discrete_Choices => New_List ( | |
3106 | Make_Others_Choice (Loc)), | |
3107 | Statements => New_List (Except)); | |
3108 | ||
2c011bc5 | 3109 | begin |
3110 | Append (New_Alt, Alternatives (N)); | |
3111 | Analyze_And_Resolve (Except); | |
3112 | end; | |
3113 | ||
3114 | else | |
3115 | Set_Others_Discrete_Choices | |
3116 | (Others_Node, Discrete_Choices (Last_Alt)); | |
3117 | Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); | |
3118 | end if; | |
3119 | ||
9dfe12ae | 3120 | end if; |
f239f5be | 3121 | |
f65f7fdf | 3122 | -- Deal with possible declarations of controlled objects, and also |
3123 | -- with rewriting choice sequences for static predicate references. | |
3124 | ||
3125 | Alt := First_Non_Pragma (Alternatives (N)); | |
3126 | while Present (Alt) loop | |
cf580b1d | 3127 | |
3128 | -- Do not consider controlled objects found in a case statement | |
3129 | -- which actually models a case expression because their early | |
3130 | -- finalization will affect the result of the expression. | |
3131 | ||
3132 | if not From_Conditional_Expression (N) then | |
3133 | Process_Statements_For_Controlled_Objects (Alt); | |
3134 | end if; | |
a7759212 | 3135 | |
3136 | if Has_SP_Choice (Alt) then | |
3137 | Expand_Static_Predicates_In_Choices (Alt); | |
3138 | end if; | |
3139 | ||
f65f7fdf | 3140 | Next_Non_Pragma (Alt); |
f239f5be | 3141 | end loop; |
9dfe12ae | 3142 | end; |
ee6ba406 | 3143 | end Expand_N_Case_Statement; |
3144 | ||
3145 | ----------------------------- | |
3146 | -- Expand_N_Exit_Statement -- | |
3147 | ----------------------------- | |
3148 | ||
3149 | -- The only processing required is to deal with a possible C/Fortran | |
3150 | -- boolean value used as the condition for the exit statement. | |
3151 | ||
3152 | procedure Expand_N_Exit_Statement (N : Node_Id) is | |
3153 | begin | |
3154 | Adjust_Condition (Condition (N)); | |
3155 | end Expand_N_Exit_Statement; | |
3156 | ||
b3f8228a | 3157 | ---------------------------------- |
3158 | -- Expand_Formal_Container_Loop -- | |
3159 | ---------------------------------- | |
3160 | ||
cdf1647b | 3161 | procedure Expand_Formal_Container_Loop (N : Node_Id) is |
5021a618 | 3162 | Loc : constant Source_Ptr := Sloc (N); |
b3f8228a | 3163 | Isc : constant Node_Id := Iteration_Scheme (N); |
3164 | I_Spec : constant Node_Id := Iterator_Specification (Isc); | |
3165 | Cursor : constant Entity_Id := Defining_Identifier (I_Spec); | |
3166 | Container : constant Node_Id := Entity (Name (I_Spec)); | |
3167 | Stats : constant List_Id := Statements (N); | |
b3f8228a | 3168 | |
2f29736b | 3169 | Advance : Node_Id; |
3170 | Init_Decl : Node_Id; | |
cfd4c24f | 3171 | Init_Name : Entity_Id; |
2f29736b | 3172 | New_Loop : Node_Id; |
b3f8228a | 3173 | |
3174 | begin | |
2f29736b | 3175 | -- The expansion of a formal container loop resembles the one for Ada |
3176 | -- containers. The only difference is that the primitives mention the | |
3177 | -- domain of iteration explicitly, and function First applied to the | |
3178 | -- container yields a cursor directly. | |
b3f8228a | 3179 | |
3180 | -- Cursor : Cursor_type := First (Container); | |
3181 | -- while Has_Element (Cursor, Container) loop | |
3182 | -- <original loop statements> | |
3183 | -- Cursor := Next (Container, Cursor); | |
3184 | -- end loop; | |
3185 | ||
cdf1647b | 3186 | Build_Formal_Container_Iteration |
2f29736b | 3187 | (N, Container, Cursor, Init_Decl, Advance, New_Loop); |
b3f8228a | 3188 | |
cdf1647b | 3189 | Append_To (Stats, Advance); |
3190 | ||
2f29736b | 3191 | -- Build a block to capture declaration of the cursor |
5021a618 | 3192 | |
2f29736b | 3193 | Rewrite (N, |
5021a618 | 3194 | Make_Block_Statement (Loc, |
2f29736b | 3195 | Declarations => New_List (Init_Decl), |
5021a618 | 3196 | Handled_Statement_Sequence => |
3197 | Make_Handled_Sequence_Of_Statements (Loc, | |
2f29736b | 3198 | Statements => New_List (New_Loop)))); |
3199 | ||
3200 | -- The loop parameter is declared by an object declaration, but within | |
3201 | -- the loop we must prevent user assignments to it, so we analyze the | |
3202 | -- declaration and reset the entity kind, before analyzing the rest of | |
3203 | -- the loop. | |
3204 | ||
3205 | Analyze (Init_Decl); | |
cfd4c24f | 3206 | Init_Name := Defining_Identifier (Init_Decl); |
3207 | Set_Ekind (Init_Name, E_Loop_Parameter); | |
2f29736b | 3208 | |
3209 | -- The cursor was marked as a loop parameter to prevent user assignments | |
3210 | -- to it, however this renders the advancement step illegal as it is not | |
3211 | -- possible to change the value of a constant. Flag the advancement step | |
3212 | -- as a legal form of assignment to remedy this side effect. | |
3213 | ||
3214 | Set_Assignment_OK (Name (Advance)); | |
5021a618 | 3215 | Analyze (N); |
882b5ac8 | 3216 | |
3217 | -- Because we have to analyze the initial declaration of the loop | |
3218 | -- parameter multiple times its scope is incorrectly set at this point | |
3219 | -- to the one surrounding the block statement - so set the scope | |
cfd4c24f | 3220 | -- manually to be the actual block statement, and indicate that it is |
3221 | -- not visible after the block has been analyzed. | |
882b5ac8 | 3222 | |
cfd4c24f | 3223 | Set_Scope (Init_Name, Entity (Identifier (N))); |
3224 | Set_Is_Immediately_Visible (Init_Name, False); | |
cdf1647b | 3225 | end Expand_Formal_Container_Loop; |
3226 | ||
3227 | ------------------------------------------ | |
3228 | -- Expand_Formal_Container_Element_Loop -- | |
3229 | ------------------------------------------ | |
3230 | ||
3231 | procedure Expand_Formal_Container_Element_Loop (N : Node_Id) is | |
3232 | Loc : constant Source_Ptr := Sloc (N); | |
3233 | Isc : constant Node_Id := Iteration_Scheme (N); | |
3234 | I_Spec : constant Node_Id := Iterator_Specification (Isc); | |
3235 | Element : constant Entity_Id := Defining_Identifier (I_Spec); | |
3236 | Container : constant Node_Id := Entity (Name (I_Spec)); | |
ba33856e | 3237 | Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); |
cdf1647b | 3238 | Stats : constant List_Id := Statements (N); |
3239 | ||
3240 | Cursor : constant Entity_Id := | |
3241 | Make_Defining_Identifier (Loc, | |
630b6d55 | 3242 | Chars => New_External_Name (Chars (Element), 'C')); |
cdf1647b | 3243 | Elmt_Decl : Node_Id; |
3244 | Elmt_Ref : Node_Id; | |
3245 | ||
630b6d55 | 3246 | Element_Op : constant Entity_Id := |
3247 | Get_Iterable_Type_Primitive (Container_Typ, Name_Element); | |
cdf1647b | 3248 | |
3249 | Advance : Node_Id; | |
3250 | Init : Node_Id; | |
3251 | New_Loop : Node_Id; | |
b3f8228a | 3252 | |
cdf1647b | 3253 | begin |
3254 | -- For an element iterator, the Element aspect must be present, | |
3255 | -- (this is checked during analysis) and the expansion takes the form: | |
3256 | ||
f10fcdcc | 3257 | -- Cursor : Cursor_Type := First (Container); |
cdf1647b | 3258 | -- Elmt : Element_Type; |
3259 | -- while Has_Element (Cursor, Container) loop | |
3260 | -- Elmt := Element (Container, Cursor); | |
3261 | -- <original loop statements> | |
3262 | -- Cursor := Next (Container, Cursor); | |
3263 | -- end loop; | |
3264 | ||
4f6fa17d | 3265 | -- However this expansion is not legal if the element is indefinite. |
3266 | -- In that case we create a block to hold a variable declaration | |
3267 | -- initialized with a call to Element, and generate: | |
3268 | ||
f10fcdcc | 3269 | -- Cursor : Cursor_Type := First (Container); |
4f6fa17d | 3270 | -- while Has_Element (Cursor, Container) loop |
3271 | -- declare | |
f10fcdcc | 3272 | -- Elmt : Element_Type := Element (Container, Cursor); |
4f6fa17d | 3273 | -- begin |
3274 | -- <original loop statements> | |
3275 | -- Cursor := Next (Container, Cursor); | |
3276 | -- end; | |
3277 | -- end loop; | |
3278 | ||
cdf1647b | 3279 | Build_Formal_Container_Iteration |
3280 | (N, Container, Cursor, Init, Advance, New_Loop); | |
4f6fa17d | 3281 | Append_To (Stats, Advance); |
cdf1647b | 3282 | |
3283 | Set_Ekind (Cursor, E_Variable); | |
b3f8228a | 3284 | Insert_Action (N, Init); |
3285 | ||
c2abf40e | 3286 | -- The loop parameter is declared by an object declaration, but within |
3287 | -- the loop we must prevent user assignments to it; the following flag | |
3288 | -- accomplishes that. | |
3289 | ||
3290 | Set_Is_Loop_Parameter (Element); | |
3291 | ||
f10fcdcc | 3292 | -- Declaration for Element |
cdf1647b | 3293 | |
630b6d55 | 3294 | Elmt_Decl := |
3295 | Make_Object_Declaration (Loc, | |
3296 | Defining_Identifier => Element, | |
3297 | Object_Definition => New_Occurrence_Of (Etype (Element_Op), Loc)); | |
cdf1647b | 3298 | |
4f6fa17d | 3299 | if not Is_Constrained (Etype (Element_Op)) then |
3300 | Set_Expression (Elmt_Decl, | |
3301 | Make_Function_Call (Loc, | |
3302 | Name => New_Occurrence_Of (Element_Op, Loc), | |
3303 | Parameter_Associations => New_List ( | |
69591398 | 3304 | Convert_To_Iterable_Type (Container, Loc), |
4f6fa17d | 3305 | New_Occurrence_Of (Cursor, Loc)))); |
e9dae6c3 | 3306 | |
4f6fa17d | 3307 | Set_Statements (New_Loop, |
3308 | New_List | |
3309 | (Make_Block_Statement (Loc, | |
3310 | Declarations => New_List (Elmt_Decl), | |
3311 | Handled_Statement_Sequence => | |
3312 | Make_Handled_Sequence_Of_Statements (Loc, | |
40bff3a0 | 3313 | Statements => Stats)))); |
cdf1647b | 3314 | |
4f6fa17d | 3315 | else |
3316 | Elmt_Ref := | |
3317 | Make_Assignment_Statement (Loc, | |
3318 | Name => New_Occurrence_Of (Element, Loc), | |
3319 | Expression => | |
3320 | Make_Function_Call (Loc, | |
3321 | Name => New_Occurrence_Of (Element_Op, Loc), | |
3322 | Parameter_Associations => New_List ( | |
69591398 | 3323 | Convert_To_Iterable_Type (Container, Loc), |
4f6fa17d | 3324 | New_Occurrence_Of (Cursor, Loc)))); |
cdf1647b | 3325 | |
4f6fa17d | 3326 | Prepend (Elmt_Ref, Stats); |
b3f8228a | 3327 | |
0b8bd25d | 3328 | -- The element is assignable in the expanded code |
5f067114 | 3329 | |
3330 | Set_Assignment_OK (Name (Elmt_Ref)); | |
3331 | ||
4f6fa17d | 3332 | -- The loop is rewritten as a block, to hold the element declaration |
b3f8228a | 3333 | |
4f6fa17d | 3334 | New_Loop := |
3335 | Make_Block_Statement (Loc, | |
3336 | Declarations => New_List (Elmt_Decl), | |
3337 | Handled_Statement_Sequence => | |
3338 | Make_Handled_Sequence_Of_Statements (Loc, | |
40bff3a0 | 3339 | Statements => New_List (New_Loop))); |
4f6fa17d | 3340 | end if; |
cdf1647b | 3341 | |
4f6fa17d | 3342 | -- The element is only modified in expanded code, so it appears as |
3343 | -- unassigned to the warning machinery. We must suppress this spurious | |
3344 | -- warning explicitly. | |
3345 | ||
3346 | Set_Warnings_Off (Element); | |
cdf1647b | 3347 | |
b3f8228a | 3348 | Rewrite (N, New_Loop); |
40fd8b29 | 3349 | Analyze (N); |
cdf1647b | 3350 | end Expand_Formal_Container_Element_Loop; |
b3f8228a | 3351 | |
ee6ba406 | 3352 | ----------------------------- |
3353 | -- Expand_N_Goto_Statement -- | |
3354 | ----------------------------- | |
3355 | ||
3356 | -- Add poll before goto if polling active | |
3357 | ||
3358 | procedure Expand_N_Goto_Statement (N : Node_Id) is | |
3359 | begin | |
3360 | Generate_Poll_Call (N); | |
3361 | end Expand_N_Goto_Statement; | |
3362 | ||
3363 | --------------------------- | |
3364 | -- Expand_N_If_Statement -- | |
3365 | --------------------------- | |
3366 | ||
21ec6442 | 3367 | -- First we deal with the case of C and Fortran convention boolean values, |
3368 | -- with zero/non-zero semantics. | |
ee6ba406 | 3369 | |
3370 | -- Second, we deal with the obvious rewriting for the cases where the | |
3371 | -- condition of the IF is known at compile time to be True or False. | |
3372 | ||
be5e6450 | 3373 | -- Third, we remove elsif parts which have non-empty Condition_Actions and |
3374 | -- rewrite as independent if statements. For example: | |
ee6ba406 | 3375 | |
3376 | -- if x then xs | |
3377 | -- elsif y then ys | |
3378 | -- ... | |
3379 | -- end if; | |
3380 | ||
3381 | -- becomes | |
3382 | -- | |
3383 | -- if x then xs | |
3384 | -- else | |
3385 | -- <<condition actions of y>> | |
3386 | -- if y then ys | |
3387 | -- ... | |
3388 | -- end if; | |
3389 | -- end if; | |
3390 | ||
3391 | -- This rewriting is needed if at least one elsif part has a non-empty | |
21ec6442 | 3392 | -- Condition_Actions list. We also do the same processing if there is a |
3393 | -- constant condition in an elsif part (in conjunction with the first | |
ee6ba406 | 3394 | -- processing step mentioned above, for the recursive call made to deal |
3395 | -- with the created inner if, this deals with properly optimizing the | |
3396 | -- cases of constant elsif conditions). | |
3397 | ||
3398 | procedure Expand_N_If_Statement (N : Node_Id) is | |
9dfe12ae | 3399 | Loc : constant Source_Ptr := Sloc (N); |
ee6ba406 | 3400 | Hed : Node_Id; |
3401 | E : Node_Id; | |
3402 | New_If : Node_Id; | |
3403 | ||
a2feb922 | 3404 | Warn_If_Deleted : constant Boolean := |
3405 | Warn_On_Deleted_Code and then Comes_From_Source (N); | |
3406 | -- Indicates whether we want warnings when we delete branches of the | |
3407 | -- if statement based on constant condition analysis. We never want | |
3408 | -- these warnings for expander generated code. | |
3409 | ||
ee6ba406 | 3410 | begin |
cf580b1d | 3411 | -- Do not consider controlled objects found in an if statement which |
3412 | -- actually models an if expression because their early finalization | |
3413 | -- will affect the result of the expression. | |
3414 | ||
3415 | if not From_Conditional_Expression (N) then | |
3416 | Process_Statements_For_Controlled_Objects (N); | |
3417 | end if; | |
f239f5be | 3418 | |
ee6ba406 | 3419 | Adjust_Condition (Condition (N)); |
3420 | ||
3421 | -- The following loop deals with constant conditions for the IF. We | |
3422 | -- need a loop because as we eliminate False conditions, we grab the | |
3423 | -- first elsif condition and use it as the primary condition. | |
3424 | ||
3425 | while Compile_Time_Known_Value (Condition (N)) loop | |
3426 | ||
21ec6442 | 3427 | -- If condition is True, we can simply rewrite the if statement now |
3428 | -- by replacing it by the series of then statements. | |
ee6ba406 | 3429 | |
3430 | if Is_True (Expr_Value (Condition (N))) then | |
3431 | ||
3432 | -- All the else parts can be killed | |
3433 | ||
a2feb922 | 3434 | Kill_Dead_Code (Elsif_Parts (N), Warn_If_Deleted); |
3435 | Kill_Dead_Code (Else_Statements (N), Warn_If_Deleted); | |
ee6ba406 | 3436 | |
3437 | Hed := Remove_Head (Then_Statements (N)); | |
3438 | Insert_List_After (N, Then_Statements (N)); | |
3439 | Rewrite (N, Hed); | |
3440 | return; | |
3441 | ||
3442 | -- If condition is False, then we can delete the condition and | |
3443 | -- the Then statements | |
3444 | ||
3445 | else | |
21ec6442 | 3446 | -- We do not delete the condition if constant condition warnings |
3447 | -- are enabled, since otherwise we end up deleting the desired | |
3448 | -- warning. Of course the backend will get rid of this True/False | |
3449 | -- test anyway, so nothing is lost here. | |
c2b56224 | 3450 | |
57f302e5 | 3451 | if not Constant_Condition_Warnings then |
3452 | Kill_Dead_Code (Condition (N)); | |
3453 | end if; | |
3454 | ||
a2feb922 | 3455 | Kill_Dead_Code (Then_Statements (N), Warn_If_Deleted); |
ee6ba406 | 3456 | |
21ec6442 | 3457 | -- If there are no elsif statements, then we simply replace the |
3458 | -- entire if statement by the sequence of else statements. | |
ee6ba406 | 3459 | |
3460 | if No (Elsif_Parts (N)) then | |
ee6ba406 | 3461 | if No (Else_Statements (N)) |
3462 | or else Is_Empty_List (Else_Statements (N)) | |
3463 | then | |
3464 | Rewrite (N, | |
3465 | Make_Null_Statement (Sloc (N))); | |
ee6ba406 | 3466 | else |
3467 | Hed := Remove_Head (Else_Statements (N)); | |
3468 | Insert_List_After (N, Else_Statements (N)); | |
3469 | Rewrite (N, Hed); | |
3470 | end if; | |
3471 | ||
3472 | return; | |
3473 | ||
21ec6442 | 3474 | -- If there are elsif statements, the first of them becomes the |
3475 | -- if/then section of the rebuilt if statement This is the case | |
3476 | -- where we loop to reprocess this copied condition. | |
ee6ba406 | 3477 | |
3478 | else | |
3479 | Hed := Remove_Head (Elsif_Parts (N)); | |
3480 | Insert_Actions (N, Condition_Actions (Hed)); | |
3481 | Set_Condition (N, Condition (Hed)); | |
3482 | Set_Then_Statements (N, Then_Statements (Hed)); | |
3483 | ||
3afcdce0 | 3484 | -- Hed might have been captured as the condition determining |
3485 | -- the current value for an entity. Now it is detached from | |
3486 | -- the tree, so a Current_Value pointer in the condition might | |
3487 | -- need to be updated. | |
3488 | ||
0326143c | 3489 | Set_Current_Value_Condition (N); |
3afcdce0 | 3490 | |
ee6ba406 | 3491 | if Is_Empty_List (Elsif_Parts (N)) then |
3492 | Set_Elsif_Parts (N, No_List); | |
3493 | end if; | |
3494 | end if; | |
3495 | end if; | |
3496 | end loop; | |
3497 | ||
3498 | -- Loop through elsif parts, dealing with constant conditions and | |
d5be9f38 | 3499 | -- possible condition actions that are present. |
ee6ba406 | 3500 | |
3501 | if Present (Elsif_Parts (N)) then | |
3502 | E := First (Elsif_Parts (N)); | |
3503 | while Present (E) loop | |
cf580b1d | 3504 | |
3505 | -- Do not consider controlled objects found in an if statement | |
3506 | -- which actually models an if expression because their early | |
3507 | -- finalization will affect the result of the expression. | |
3508 | ||
3509 | if not From_Conditional_Expression (N) then | |
3510 | Process_Statements_For_Controlled_Objects (E); | |
3511 | end if; | |
f239f5be | 3512 | |
ee6ba406 | 3513 | Adjust_Condition (Condition (E)); |
3514 | ||
21ec6442 | 3515 | -- If there are condition actions, then rewrite the if statement |
3516 | -- as indicated above. We also do the same rewrite for a True or | |
3517 | -- False condition. The further processing of this constant | |
3518 | -- condition is then done by the recursive call to expand the | |
3519 | -- newly created if statement | |
ee6ba406 | 3520 | |
3521 | if Present (Condition_Actions (E)) | |
3522 | or else Compile_Time_Known_Value (Condition (E)) | |
3523 | then | |
ee6ba406 | 3524 | New_If := |
3525 | Make_If_Statement (Sloc (E), | |
3526 | Condition => Condition (E), | |
3527 | Then_Statements => Then_Statements (E), | |
3528 | Elsif_Parts => No_List, | |
3529 | Else_Statements => Else_Statements (N)); | |
3530 | ||
3531 | -- Elsif parts for new if come from remaining elsif's of parent | |
3532 | ||
3533 | while Present (Next (E)) loop | |
3534 | if No (Elsif_Parts (New_If)) then | |
3535 | Set_Elsif_Parts (New_If, New_List); | |
3536 | end if; | |
3537 | ||
3538 | Append (Remove_Next (E), Elsif_Parts (New_If)); | |
3539 | end loop; | |
3540 | ||
3541 | Set_Else_Statements (N, New_List (New_If)); | |
3542 | ||
3543 | if Present (Condition_Actions (E)) then | |
3544 | Insert_List_Before (New_If, Condition_Actions (E)); | |
3545 | end if; | |
3546 | ||
3547 | Remove (E); | |
3548 | ||
3549 | if Is_Empty_List (Elsif_Parts (N)) then | |
3550 | Set_Elsif_Parts (N, No_List); | |
3551 | end if; | |
3552 | ||
3553 | Analyze (New_If); | |
5d5958da | 3554 | |
3555 | -- Note this is not an implicit if statement, since it is part | |
3556 | -- of an explicit if statement in the source (or of an implicit | |
3557 | -- if statement that has already been tested). We set the flag | |
3558 | -- after calling Analyze to avoid generating extra warnings | |
3559 | -- specific to pure if statements, however (see | |
3560 | -- Sem_Ch5.Analyze_If_Statement). | |
3561 | ||
3562 | Set_Comes_From_Source (New_If, Comes_From_Source (N)); | |
ee6ba406 | 3563 | return; |
3564 | ||
3565 | -- No special processing for that elsif part, move to next | |
3566 | ||
3567 | else | |
3568 | Next (E); | |
3569 | end if; | |
3570 | end loop; | |
3571 | end if; | |
9dfe12ae | 3572 | |
3573 | -- Some more optimizations applicable if we still have an IF statement | |
3574 | ||
3575 | if Nkind (N) /= N_If_Statement then | |
3576 | return; | |
3577 | end if; | |
3578 | ||
3579 | -- Another optimization, special cases that can be simplified | |
3580 | ||
3581 | -- if expression then | |
3582 | -- return true; | |
3583 | -- else | |
3584 | -- return false; | |
3585 | -- end if; | |
3586 | ||
3587 | -- can be changed to: | |
3588 | ||
3589 | -- return expression; | |
3590 | ||
3591 | -- and | |
3592 | ||
3593 | -- if expression then | |
3594 | -- return false; | |
3595 | -- else | |
3596 | -- return true; | |
3597 | -- end if; | |
3598 | ||
3599 | -- can be changed to: | |
3600 | ||
3601 | -- return not (expression); | |
3602 | ||
12e8797f | 3603 | -- Only do these optimizations if we are at least at -O1 level and |
3604 | -- do not do them if control flow optimizations are suppressed. | |
9dfe12ae | 3605 | |
12e8797f | 3606 | if Optimization_Level > 0 |
3607 | and then not Opt.Suppress_Control_Flow_Optimizations | |
3608 | then | |
d55c93e0 | 3609 | if Nkind (N) = N_If_Statement |
3610 | and then No (Elsif_Parts (N)) | |
3611 | and then Present (Else_Statements (N)) | |
3612 | and then List_Length (Then_Statements (N)) = 1 | |
3613 | and then List_Length (Else_Statements (N)) = 1 | |
3614 | then | |
3615 | declare | |
3616 | Then_Stm : constant Node_Id := First (Then_Statements (N)); | |
3617 | Else_Stm : constant Node_Id := First (Else_Statements (N)); | |
9dfe12ae | 3618 | |
d55c93e0 | 3619 | begin |
3620 | if Nkind (Then_Stm) = N_Simple_Return_Statement | |
3621 | and then | |
3622 | Nkind (Else_Stm) = N_Simple_Return_Statement | |
3623 | then | |
3624 | declare | |
3625 | Then_Expr : constant Node_Id := Expression (Then_Stm); | |
3626 | Else_Expr : constant Node_Id := Expression (Else_Stm); | |
3627 | ||
3628 | begin | |
3629 | if Nkind (Then_Expr) = N_Identifier | |
3630 | and then | |
3631 | Nkind (Else_Expr) = N_Identifier | |
9dfe12ae | 3632 | then |
d55c93e0 | 3633 | if Entity (Then_Expr) = Standard_True |
3634 | and then Entity (Else_Expr) = Standard_False | |
3635 | then | |
3636 | Rewrite (N, | |
3637 | Make_Simple_Return_Statement (Loc, | |
3638 | Expression => Relocate_Node (Condition (N)))); | |
3639 | Analyze (N); | |
3640 | return; | |
3641 | ||
3642 | elsif Entity (Then_Expr) = Standard_False | |
3643 | and then Entity (Else_Expr) = Standard_True | |
3644 | then | |
3645 | Rewrite (N, | |
3646 | Make_Simple_Return_Statement (Loc, | |
3647 | Expression => | |
3648 | Make_Op_Not (Loc, | |
3649 | Right_Opnd => | |
3650 | Relocate_Node (Condition (N))))); | |
3651 | Analyze (N); | |
3652 | return; | |
3653 | end if; | |
9dfe12ae | 3654 | end if; |
d55c93e0 | 3655 | end; |
3656 | end if; | |
3657 | end; | |
3658 | end if; | |
9dfe12ae | 3659 | end if; |
ee6ba406 | 3660 | end Expand_N_If_Statement; |
3661 | ||
f37e6e70 | 3662 | -------------------------- |
3663 | -- Expand_Iterator_Loop -- | |
3664 | -------------------------- | |
3665 | ||
3666 | procedure Expand_Iterator_Loop (N : Node_Id) is | |
52f5f002 | 3667 | Isc : constant Node_Id := Iteration_Scheme (N); |
3668 | I_Spec : constant Node_Id := Iterator_Specification (Isc); | |
d9f170d4 | 3669 | |
461c69f7 | 3670 | Container : constant Node_Id := Name (I_Spec); |
3671 | Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); | |
f37e6e70 | 3672 | |
3673 | begin | |
52f5f002 | 3674 | -- Processing for arrays |
3675 | ||
3676 | if Is_Array_Type (Container_Typ) then | |
b7974341 | 3677 | pragma Assert (Of_Present (I_Spec)); |
1b989431 | 3678 | Expand_Iterator_Loop_Over_Array (N); |
b3f8228a | 3679 | |
3680 | elsif Has_Aspect (Container_Typ, Aspect_Iterable) then | |
cdf1647b | 3681 | if Of_Present (I_Spec) then |
3682 | Expand_Formal_Container_Element_Loop (N); | |
3683 | else | |
3684 | Expand_Formal_Container_Loop (N); | |
3685 | end if; | |
630b6d55 | 3686 | |
1b989431 | 3687 | -- Processing for containers |
52f5f002 | 3688 | |
b7974341 | 3689 | else |
3690 | Expand_Iterator_Loop_Over_Container | |
3691 | (N, Isc, I_Spec, Container, Container_Typ); | |
3692 | end if; | |
1b989431 | 3693 | end Expand_Iterator_Loop; |
f37e6e70 | 3694 | |
1b989431 | 3695 | ------------------------------------- |
3696 | -- Expand_Iterator_Loop_Over_Array -- | |
3697 | ------------------------------------- | |
3698 | ||
3699 | procedure Expand_Iterator_Loop_Over_Array (N : Node_Id) is | |
3700 | Isc : constant Node_Id := Iteration_Scheme (N); | |
3701 | I_Spec : constant Node_Id := Iterator_Specification (Isc); | |
3702 | Array_Node : constant Node_Id := Name (I_Spec); | |
3703 | Array_Typ : constant Entity_Id := Base_Type (Etype (Array_Node)); | |
3704 | Array_Dim : constant Pos := Number_Dimensions (Array_Typ); | |
3705 | Id : constant Entity_Id := Defining_Identifier (I_Spec); | |
53d2041f | 3706 | Loc : constant Source_Ptr := Sloc (Isc); |
1b989431 | 3707 | Stats : constant List_Id := Statements (N); |
3708 | Core_Loop : Node_Id; | |
6475ce8a | 3709 | Dim1 : Int; |
1b989431 | 3710 | Ind_Comp : Node_Id; |
3711 | Iterator : Entity_Id; | |
3712 | ||
3713 | -- Start of processing for Expand_Iterator_Loop_Over_Array | |
f37e6e70 | 3714 | |
1b989431 | 3715 | begin |
3716 | -- for Element of Array loop | |
52f5f002 | 3717 | |
ea6969d4 | 3718 | -- It requires an internally generated cursor to iterate over the array |
aabafdc2 | 3719 | |
ea6969d4 | 3720 | pragma Assert (Of_Present (I_Spec)); |
b4d9f546 | 3721 | |
ea6969d4 | 3722 | Iterator := Make_Temporary (Loc, 'C'); |
b4d9f546 | 3723 | |
ea6969d4 | 3724 | -- Generate: |
3725 | -- Element : Component_Type renames Array (Iterator); | |
3726 | -- Iterator is the index value, or a list of index values | |
3727 | -- in the case of a multidimensional array. | |
3728 | ||
3729 | Ind_Comp := | |
3730 | Make_Indexed_Component (Loc, | |
3c5ca053 | 3731 | Prefix => New_Copy_Tree (Array_Node), |
ea6969d4 | 3732 | Expressions => New_List (New_Occurrence_Of (Iterator, Loc))); |
3733 | ||
3c5ca053 | 3734 | -- Propagate the original node to the copy since the analysis of the |
3735 | -- following object renaming declaration relies on the original node. | |
3736 | ||
3737 | Set_Original_Node (Prefix (Ind_Comp), Original_Node (Array_Node)); | |
3738 | ||
ea6969d4 | 3739 | Prepend_To (Stats, |
3740 | Make_Object_Renaming_Declaration (Loc, | |
3741 | Defining_Identifier => Id, | |
3742 | Subtype_Mark => | |
3743 | New_Occurrence_Of (Component_Type (Array_Typ), Loc), | |
3744 | Name => Ind_Comp)); | |
3745 | ||
3746 | -- Mark the loop variable as needing debug info, so that expansion | |
3747 | -- of the renaming will result in Materialize_Entity getting set via | |
3748 | -- Debug_Renaming_Declaration. (This setting is needed here because | |
3749 | -- the setting in Freeze_Entity comes after the expansion, which is | |
3750 | -- too late. ???) | |
3751 | ||
3752 | Set_Debug_Info_Needed (Id); | |
a053db0d | 3753 | |
1b989431 | 3754 | -- Generate: |
3755 | ||
3756 | -- for Iterator in [reverse] Array'Range (Array_Dim) loop | |
3757 | -- Element : Component_Type renames Array (Iterator); | |
3758 | -- <original loop statements> | |
3759 | -- end loop; | |
3760 | ||
6475ce8a | 3761 | -- If this is an iteration over a multidimensional array, the |
3762 | -- innermost loop is over the last dimension in Ada, and over | |
3763 | -- the first dimension in Fortran. | |
3764 | ||
3765 | if Convention (Array_Typ) = Convention_Fortran then | |
3766 | Dim1 := 1; | |
3767 | else | |
3768 | Dim1 := Array_Dim; | |
3769 | end if; | |
3770 | ||
1b989431 | 3771 | Core_Loop := |
53d2041f | 3772 | Make_Loop_Statement (Sloc (N), |
1b989431 | 3773 | Iteration_Scheme => |
3774 | Make_Iteration_Scheme (Loc, | |
3775 | Loop_Parameter_Specification => | |
3776 | Make_Loop_Parameter_Specification (Loc, | |
3777 | Defining_Identifier => Iterator, | |
3778 | Discrete_Subtype_Definition => | |
3779 | Make_Attribute_Reference (Loc, | |
3c5ca053 | 3780 | Prefix => New_Copy_Tree (Array_Node), |
1b989431 | 3781 | Attribute_Name => Name_Range, |
3782 | Expressions => New_List ( | |
6475ce8a | 3783 | Make_Integer_Literal (Loc, Dim1))), |
1b989431 | 3784 | Reverse_Present => Reverse_Present (I_Spec))), |
3785 | Statements => Stats, | |
3786 | End_Label => Empty); | |
3787 | ||
6475ce8a | 3788 | -- Processing for multidimensional array. The body of each loop is |
3789 | -- a loop over a previous dimension, going in decreasing order in Ada | |
3790 | -- and in increasing order in Fortran. | |
1b989431 | 3791 | |
3792 | if Array_Dim > 1 then | |
3793 | for Dim in 1 .. Array_Dim - 1 loop | |
6475ce8a | 3794 | if Convention (Array_Typ) = Convention_Fortran then |
3795 | Dim1 := Dim + 1; | |
3796 | else | |
3797 | Dim1 := Array_Dim - Dim; | |
3798 | end if; | |
3799 | ||
1b989431 | 3800 | Iterator := Make_Temporary (Loc, 'C'); |
52f5f002 | 3801 | |
1b989431 | 3802 | -- Generate the dimension loops starting from the innermost one |
f37e6e70 | 3803 | |
1b989431 | 3804 | -- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop |
3805 | -- <core loop> | |
4dec6b60 | 3806 | -- end loop; |
4ada9c32 | 3807 | |
1b989431 | 3808 | Core_Loop := |
53d2041f | 3809 | Make_Loop_Statement (Sloc (N), |
4dec6b60 | 3810 | Iteration_Scheme => |
3811 | Make_Iteration_Scheme (Loc, | |
1b989431 | 3812 | Loop_Parameter_Specification => |
3813 | Make_Loop_Parameter_Specification (Loc, | |
3814 | Defining_Identifier => Iterator, | |
3815 | Discrete_Subtype_Definition => | |
3816 | Make_Attribute_Reference (Loc, | |
3c5ca053 | 3817 | Prefix => New_Copy_Tree (Array_Node), |
1b989431 | 3818 | Attribute_Name => Name_Range, |
3819 | Expressions => New_List ( | |
6475ce8a | 3820 | Make_Integer_Literal (Loc, Dim1))), |
1b989431 | 3821 | Reverse_Present => Reverse_Present (I_Spec))), |
3822 | Statements => New_List (Core_Loop), | |
3823 | End_Label => Empty); | |
3824 | ||
3825 | -- Update the previously created object renaming declaration with | |
6475ce8a | 3826 | -- the new iterator, by adding the index of the next loop to the |
3827 | -- indexed component, in the order that corresponds to the | |
3828 | -- convention. | |
1b989431 | 3829 | |
6475ce8a | 3830 | if Convention (Array_Typ) = Convention_Fortran then |
3831 | Append_To (Expressions (Ind_Comp), | |
3832 | New_Occurrence_Of (Iterator, Loc)); | |
3833 | else | |
3834 | Prepend_To (Expressions (Ind_Comp), | |
3835 | New_Occurrence_Of (Iterator, Loc)); | |
3836 | end if; | |
1b989431 | 3837 | end loop; |
f37e6e70 | 3838 | end if; |
3839 | ||
6aa09900 | 3840 | -- Inherit the loop identifier from the original loop. This ensures that |
3841 | -- the scope stack is consistent after the rewriting. | |
8f531643 | 3842 | |
6aa09900 | 3843 | if Present (Identifier (N)) then |
8f531643 | 3844 | Set_Identifier (Core_Loop, Relocate_Node (Identifier (N))); |
3845 | end if; | |
3846 | ||
1b989431 | 3847 | Rewrite (N, Core_Loop); |
f37e6e70 | 3848 | Analyze (N); |
1b989431 | 3849 | end Expand_Iterator_Loop_Over_Array; |
f37e6e70 | 3850 | |
b7974341 | 3851 | ----------------------------------------- |
3852 | -- Expand_Iterator_Loop_Over_Container -- | |
3853 | ----------------------------------------- | |
3854 | ||
3855 | -- For a 'for ... in' loop, such as: | |
3856 | ||
3857 | -- for Cursor in Iterator_Function (...) loop | |
3858 | -- ... | |
3859 | -- end loop; | |
3860 | ||
3861 | -- we generate: | |
3862 | ||
3863 | -- Iter : Iterator_Type := Iterator_Function (...); | |
3864 | -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse" | |
3865 | -- while Has_Element (Cursor) loop | |
3866 | -- ... | |
3867 | -- | |
3868 | -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse" | |
3869 | -- end loop; | |
3870 | ||
3871 | -- For a 'for ... of' loop, such as: | |
3872 | ||
3873 | -- for X of Container loop | |
3874 | -- ... | |
3875 | -- end loop; | |
3876 | ||
3877 | -- the RM implies the generation of: | |
3878 | ||
3879 | -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator | |
3880 | -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse" | |
3881 | -- while Has_Element (Cursor) loop | |
3882 | -- declare | |
3883 | -- X : Element_Type renames Element (Cursor).Element.all; | |
3884 | -- -- or Constant_Element | |
3885 | -- begin | |
3886 | -- ... | |
3887 | -- end; | |
3888 | -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse" | |
3889 | -- end loop; | |
3890 | ||
3891 | -- In the general case, we do what the RM says. However, the operations | |
3892 | -- Element and Iter.Next are slow, which is bad inside a loop, because they | |
3893 | -- involve dispatching via interfaces, secondary stack manipulation, | |
3894 | -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the | |
3895 | -- predefined containers, we use an equivalent but optimized expansion. | |
3896 | ||
3897 | -- In the optimized case, we make use of these: | |
3898 | ||
3899 | -- procedure Next (Position : in out Cursor); -- instead of Iter.Next | |
3900 | ||
3901 | -- function Pseudo_Reference | |
3902 | -- (Container : aliased Vector'Class) return Reference_Control_Type; | |
3903 | ||
3904 | -- type Element_Access is access all Element_Type; | |
3905 | ||
3906 | -- function Get_Element_Access | |
3907 | -- (Position : Cursor) return not null Element_Access; | |
3908 | ||
3909 | -- Next is declared in the visible part of the container packages. | |
3910 | -- The other three are added in the private part. (We're not supposed to | |
3911 | -- pollute the namespace for clients. The compiler has no trouble breaking | |
3912 | -- privacy to call things in the private part of an instance.) | |
3913 | ||
3914 | -- Source: | |
3915 | ||
3916 | -- for X of My_Vector loop | |
3917 | -- X.Count := X.Count + 1; | |
3918 | -- ... | |
3919 | -- end loop; | |
3920 | ||
3921 | -- The compiler will generate: | |
3922 | ||
3923 | -- Iter : Reversible_Iterator'Class := Iterate (My_Vector); | |
3924 | -- -- Reversible_Iterator is an interface. Iterate is the | |
3925 | -- -- Default_Iterator aspect of Vector. This increments Lock, | |
3926 | -- -- disallowing tampering with cursors. Unfortunately, it does not | |
3927 | -- -- increment Busy. The result of Iterate is Limited_Controlled; | |
06d78d4c | 3928 | -- -- finalization will decrement Lock. This is a build-in-place |
b7974341 | 3929 | -- -- dispatching call to Iterate. |
3930 | ||
3931 | -- Cur : Cursor := First (Iter); -- or Last | |
3932 | -- -- Dispatching call via interface. | |
3933 | ||
3934 | -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector); | |
3935 | -- -- Pseudo_Reference increments Busy, to detect tampering with | |
3936 | -- -- elements, as required by RM. Also redundantly increment | |
3937 | -- -- Lock. Finalization of Control will decrement both Busy and | |
3938 | -- -- Lock. Pseudo_Reference returns a record containing a pointer to | |
3939 | -- -- My_Vector, used by Finalize. | |
3940 | -- -- | |
3941 | -- -- Control is not used below, except to finalize it -- it's purely | |
3942 | -- -- an RAII thing. This is needed because we are eliminating the | |
3943 | -- -- call to Reference within the loop. | |
3944 | ||
3945 | -- while Has_Element (Cur) loop | |
3946 | -- declare | |
3947 | -- X : My_Element renames Get_Element_Access (Cur).all; | |
3948 | -- -- Get_Element_Access returns a pointer to the element | |
3949 | -- -- designated by Cur. No dispatching here, and no horsing | |
3950 | -- -- around with access discriminants. This is instead of the | |
3951 | -- -- existing | |
3952 | -- -- | |
3953 | -- -- X : My_Element renames Reference (Cur).Element.all; | |
3954 | -- -- | |
3955 | -- -- which creates a controlled object. | |
3956 | -- begin | |
3957 | -- -- Any attempt to tamper with My_Vector here in the loop | |
3958 | -- -- will correctly raise Program_Error, because of the | |
3959 | -- -- Control. | |
3960 | -- | |
3961 | -- X.Count := X.Count + 1; | |
3962 | -- ... | |
3963 | -- | |
3964 | -- Next (Cur); -- or Prev | |
3965 | -- -- This is instead of "Cur := Next (Iter, Cur);" | |
3966 | -- end; | |
3967 | -- -- No finalization here | |
3968 | -- end loop; | |
3969 | -- Finalize Iter and Control here, decrementing Lock twice and Busy | |
3970 | -- once. | |
3971 | ||
3972 | -- This optimization makes "for ... of" loops over 30 times faster in cases | |
3973 | -- measured. | |
3974 | ||
3975 | procedure Expand_Iterator_Loop_Over_Container | |
3976 | (N : Node_Id; | |
3977 | Isc : Node_Id; | |
3978 | I_Spec : Node_Id; | |
3979 | Container : Node_Id; | |
3980 | Container_Typ : Entity_Id) | |
3981 | is | |
02e5d0d0 | 3982 | Id : constant Entity_Id := Defining_Identifier (I_Spec); |
3983 | Elem_Typ : constant Entity_Id := Etype (Id); | |
3984 | Id_Kind : constant Entity_Kind := Ekind (Id); | |
3985 | Loc : constant Source_Ptr := Sloc (N); | |
3986 | Stats : constant List_Id := Statements (N); | |
b7974341 | 3987 | |
02e5d0d0 | 3988 | Cursor : Entity_Id; |
3989 | Decl : Node_Id; | |
3990 | Iter_Type : Entity_Id; | |
3991 | Iterator : Entity_Id; | |
3992 | Name_Init : Name_Id; | |
3993 | Name_Step : Name_Id; | |
3994 | New_Loop : Node_Id; | |
b7974341 | 3995 | |
02e5d0d0 | 3996 | Fast_Element_Access_Op : Entity_Id := Empty; |
3997 | Fast_Step_Op : Entity_Id := Empty; | |
b7974341 | 3998 | -- Only for optimized version of "for ... of" |
3999 | ||
02e5d0d0 | 4000 | Iter_Pack : Entity_Id; |
4001 | -- The package in which the iterator interface is instantiated. This is | |
4002 | -- typically an instance within the container package. | |
4003 | ||
4004 | Pack : Entity_Id; | |
4005 | -- The package in which the container type is declared | |
4006 | ||
b7974341 | 4007 | begin |
4008 | -- Determine the advancement and initialization steps for the cursor. | |
4009 | -- Analysis of the expanded loop will verify that the container has a | |
4010 | -- reverse iterator. | |
4011 | ||
4012 | if Reverse_Present (I_Spec) then | |
4013 | Name_Init := Name_Last; | |
4014 | Name_Step := Name_Previous; | |
4015 | else | |
4016 | Name_Init := Name_First; | |
4017 | Name_Step := Name_Next; | |
4018 | end if; | |
4019 | ||
4020 | -- The type of the iterator is the return type of the Iterate function | |
4021 | -- used. For the "of" form this is the default iterator for the type, | |
4022 | -- otherwise it is the type of the explicit function used in the | |
4023 | -- iterator specification. The most common case will be an Iterate | |
4024 | -- function in the container package. | |
4025 | ||
4026 | -- The Iterator type is declared in an instance within the container | |
4027 | -- package itself, for example: | |
4028 | ||
4029 | -- package Vector_Iterator_Interfaces is new | |
4030 | -- Ada.Iterator_Interfaces (Cursor, Has_Element); | |
4031 | ||
4032 | -- If the container type is a derived type, the cursor type is found in | |
4033 | -- the package of the ultimate ancestor type. | |
4034 | ||
4035 | if Is_Derived_Type (Container_Typ) then | |
4036 | Pack := Scope (Root_Type (Container_Typ)); | |
4037 | else | |
4038 | Pack := Scope (Container_Typ); | |
4039 | end if; | |
4040 | ||
b7974341 | 4041 | if Of_Present (I_Spec) then |
4042 | Handle_Of : declare | |
4043 | Container_Arg : Node_Id; | |
4044 | ||
4045 | function Get_Default_Iterator | |
4046 | (T : Entity_Id) return Entity_Id; | |
983d292f | 4047 | -- Return the default iterator for a specific type. If the type is |
4048 | -- derived, we return the inherited or overridden one if | |
4049 | -- appropriate. | |
b7974341 | 4050 | |
4051 | -------------------------- | |
4052 | -- Get_Default_Iterator -- | |
4053 | -------------------------- | |
4054 | ||
4055 | function Get_Default_Iterator | |
4056 | (T : Entity_Id) return Entity_Id | |
4057 | is | |
4058 | Iter : constant Entity_Id := | |
4059 | Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator)); | |
4060 | Prim : Elmt_Id; | |
4061 | Op : Entity_Id; | |
4062 | ||
4063 | begin | |
4064 | Container_Arg := New_Copy_Tree (Container); | |
4065 | ||
983d292f | 4066 | -- A previous version of GNAT allowed indexing aspects to be |
4067 | -- redefined on derived container types, while the default | |
4068 | -- iterator was inherited from the parent type. This | |
4069 | -- nonstandard extension is preserved for use by the | |
f4264652 | 4070 | -- modeling project under debug flag -gnatd.X. |
b7974341 | 4071 | |
4072 | if Debug_Flag_Dot_XX then | |
4073 | if Base_Type (Etype (Container)) /= | |
4074 | Base_Type (Etype (First_Formal (Iter))) | |
4075 | then | |
4076 | Container_Arg := | |
4077 | Make_Type_Conversion (Loc, | |
4078 | Subtype_Mark => | |
4079 | New_Occurrence_Of | |
4080 | (Etype (First_Formal (Iter)), Loc), | |
4081 | Expression => Container_Arg); | |
4082 | end if; | |
4083 | ||
4084 | return Iter; | |
4085 | ||
4086 | elsif Is_Derived_Type (T) then | |
4087 | ||
4088 | -- The default iterator must be a primitive operation of the | |
e60047e5 | 4089 | -- type, at the same dispatch slot position. The DT position |
4090 | -- may not be established if type is not frozen yet. | |
b7974341 | 4091 | |
4092 | Prim := First_Elmt (Primitive_Operations (T)); | |
4093 | while Present (Prim) loop | |
4094 | Op := Node (Prim); | |
4095 | ||
e60047e5 | 4096 | if Alias (Op) = Iter |
0c4abd51 | 4097 | or else |
4098 | (Chars (Op) = Chars (Iter) | |
4099 | and then Present (DTC_Entity (Op)) | |
4100 | and then DT_Position (Op) = DT_Position (Iter)) | |
b7974341 | 4101 | then |
4102 | return Op; | |
4103 | end if; | |
4104 | ||
4105 | Next_Elmt (Prim); | |
4106 | end loop; | |
4107 | ||
983d292f | 4108 | -- If we didn't find it, then our parent type is not |
4109 | -- iterable, so we return the Default_Iterator aspect of | |
4110 | -- this type. | |
b7974341 | 4111 | |
983d292f | 4112 | return Iter; |
b7974341 | 4113 | |
4114 | -- Otherwise not a derived type | |
4115 | ||
4116 | else | |
4117 | return Iter; | |
4118 | end if; | |
4119 | end Get_Default_Iterator; | |
4120 | ||
02e5d0d0 | 4121 | -- Local variables |
4122 | ||
b7974341 | 4123 | Default_Iter : Entity_Id; |
4124 | Ent : Entity_Id; | |
4125 | ||
4126 | Reference_Control_Type : Entity_Id := Empty; | |
4127 | Pseudo_Reference : Entity_Id := Empty; | |
4128 | ||
4129 | -- Start of processing for Handle_Of | |
4130 | ||
4131 | begin | |
4132 | if Is_Class_Wide_Type (Container_Typ) then | |
4133 | Default_Iter := | |
4134 | Get_Default_Iterator (Etype (Base_Type (Container_Typ))); | |
4135 | else | |
4136 | Default_Iter := Get_Default_Iterator (Etype (Container)); | |
4137 | end if; | |
4138 | ||
4139 | Cursor := Make_Temporary (Loc, 'C'); | |
4140 | ||
4141 | -- For a container element iterator, the iterator type is obtained | |
4142 | -- from the corresponding aspect, whose return type is descended | |
4143 | -- from the corresponding interface type in some instance of | |
4144 | -- Ada.Iterator_Interfaces. The actuals of that instantiation | |
4145 | -- are Cursor and Has_Element. | |
4146 | ||
4147 | Iter_Type := Etype (Default_Iter); | |
4148 | ||
02e5d0d0 | 4149 | -- The iterator type, which is a class-wide type, may itself be |
4150 | -- derived locally, so the desired instantiation is the scope of | |
4151 | -- the root type of the iterator type. | |
4152 | ||
4153 | Iter_Pack := Scope (Root_Type (Etype (Iter_Type))); | |
4154 | ||
b7974341 | 4155 | -- Find declarations needed for "for ... of" optimization |
4156 | ||
4157 | Ent := First_Entity (Pack); | |
4158 | while Present (Ent) loop | |
4159 | if Chars (Ent) = Name_Get_Element_Access then | |
4160 | Fast_Element_Access_Op := Ent; | |
4161 | ||
4162 | elsif Chars (Ent) = Name_Step | |
4163 | and then Ekind (Ent) = E_Procedure | |
4164 | then | |
4165 | Fast_Step_Op := Ent; | |
4166 | ||
4167 | elsif Chars (Ent) = Name_Reference_Control_Type then | |
4168 | Reference_Control_Type := Ent; | |
4169 | ||
4170 | elsif Chars (Ent) = Name_Pseudo_Reference then | |
4171 | Pseudo_Reference := Ent; | |
4172 | end if; | |
4173 | ||
4174 | Next_Entity (Ent); | |
4175 | end loop; | |
4176 | ||
4177 | if Present (Reference_Control_Type) | |
4178 | and then Present (Pseudo_Reference) | |
4179 | then | |
4180 | Insert_Action (N, | |
4181 | Make_Object_Declaration (Loc, | |
4182 | Defining_Identifier => Make_Temporary (Loc, 'D'), | |
4183 | Object_Definition => | |
4184 | New_Occurrence_Of (Reference_Control_Type, Loc), | |
4185 | Expression => | |
4186 | Make_Function_Call (Loc, | |
4187 | Name => | |
4188 | New_Occurrence_Of (Pseudo_Reference, Loc), | |
4189 | Parameter_Associations => | |
4190 | New_List (New_Copy_Tree (Container_Arg))))); | |
4191 | end if; | |
4192 | ||
02e5d0d0 | 4193 | -- Rewrite domain of iteration as a call to the default iterator |
4194 | -- for the container type. The formal may be an access parameter | |
4195 | -- in which case we must build a reference to the container. | |
b7974341 | 4196 | |
02e5d0d0 | 4197 | declare |
4198 | Arg : Node_Id; | |
4199 | begin | |
4200 | if Is_Access_Type (Etype (First_Entity (Default_Iter))) then | |
4201 | Arg := | |
4202 | Make_Attribute_Reference (Loc, | |
4203 | Prefix => Container_Arg, | |
4204 | Attribute_Name => Name_Unrestricted_Access); | |
4205 | else | |
4206 | Arg := Container_Arg; | |
4207 | end if; | |
b7974341 | 4208 | |
02e5d0d0 | 4209 | Rewrite (Name (I_Spec), |
4210 | Make_Function_Call (Loc, | |
4211 | Name => | |
4212 | New_Occurrence_Of (Default_Iter, Loc), | |
4213 | Parameter_Associations => New_List (Arg))); | |
4214 | end; | |
b7974341 | 4215 | |
b7974341 | 4216 | Analyze_And_Resolve (Name (I_Spec)); |
4217 | ||
4218 | -- Find cursor type in proper iterator package, which is an | |
4219 | -- instantiation of Iterator_Interfaces. | |
4220 | ||
02e5d0d0 | 4221 | Ent := First_Entity (Iter_Pack); |
b7974341 | 4222 | while Present (Ent) loop |
4223 | if Chars (Ent) = Name_Cursor then | |
4224 | Set_Etype (Cursor, Etype (Ent)); | |
4225 | exit; | |
4226 | end if; | |
4227 | ||
4228 | Next_Entity (Ent); | |
4229 | end loop; | |
4230 | ||
4231 | if Present (Fast_Element_Access_Op) then | |
4232 | Decl := | |
4233 | Make_Object_Renaming_Declaration (Loc, | |
4234 | Defining_Identifier => Id, | |
4235 | Subtype_Mark => | |
02e5d0d0 | 4236 | New_Occurrence_Of (Elem_Typ, Loc), |
b7974341 | 4237 | Name => |
4238 | Make_Explicit_Dereference (Loc, | |
4239 | Prefix => | |
4240 | Make_Function_Call (Loc, | |
4241 | Name => | |
4242 | New_Occurrence_Of (Fast_Element_Access_Op, Loc), | |
4243 | Parameter_Associations => | |
4244 | New_List (New_Occurrence_Of (Cursor, Loc))))); | |
4245 | ||
4246 | else | |
4247 | Decl := | |
4248 | Make_Object_Renaming_Declaration (Loc, | |
4249 | Defining_Identifier => Id, | |
4250 | Subtype_Mark => | |
02e5d0d0 | 4251 | New_Occurrence_Of (Elem_Typ, Loc), |
b7974341 | 4252 | Name => |
4253 | Make_Indexed_Component (Loc, | |
4254 | Prefix => Relocate_Node (Container_Arg), | |
4255 | Expressions => | |
4256 | New_List (New_Occurrence_Of (Cursor, Loc)))); | |
4257 | end if; | |
4258 | ||
02e5d0d0 | 4259 | -- The defining identifier in the iterator is user-visible and |
4260 | -- must be visible in the debugger. | |
b7974341 | 4261 | |
4262 | Set_Debug_Info_Needed (Id); | |
4263 | ||
4264 | -- If the container does not have a variable indexing aspect, | |
727cc335 | 4265 | -- the element is a constant in the loop. The container itself |
4266 | -- may be constant, in which case the element is a constant as | |
4267 | -- well. The container has been rewritten as a call to Iterate, | |
4268 | -- so examine original node. | |
b7974341 | 4269 | |
4270 | if No (Find_Value_Of_Aspect | |
4271 | (Container_Typ, Aspect_Variable_Indexing)) | |
727cc335 | 4272 | or else not Is_Variable (Original_Node (Container)) |
b7974341 | 4273 | then |
4274 | Set_Ekind (Id, E_Constant); | |
4275 | end if; | |
4276 | ||
4277 | Prepend_To (Stats, Decl); | |
4278 | end Handle_Of; | |
4279 | ||
02e5d0d0 | 4280 | -- X in Iterate (S) : type of iterator is type of explicitly given |
4281 | -- Iterate function, and the loop variable is the cursor. It will be | |
4282 | -- assigned in the loop and must be a variable. | |
b7974341 | 4283 | |
4284 | else | |
02e5d0d0 | 4285 | Iter_Type := Etype (Name (I_Spec)); |
4286 | ||
4287 | -- The iterator type, which is a class-wide type, may itself be | |
4288 | -- derived locally, so the desired instantiation is the scope of | |
4289 | -- the root type of the iterator type, as in the "of" case. | |
4290 | ||
4291 | Iter_Pack := Scope (Root_Type (Etype (Iter_Type))); | |
b7974341 | 4292 | Cursor := Id; |
4293 | end if; | |
4294 | ||
4295 | Iterator := Make_Temporary (Loc, 'I'); | |
4296 | ||
02e5d0d0 | 4297 | -- For both iterator forms, add a call to the step operation to advance |
4298 | -- the cursor. Generate: | |
b7974341 | 4299 | |
4300 | -- Cursor := Iterator.Next (Cursor); | |
4301 | ||
4302 | -- or else | |
4303 | ||
4304 | -- Cursor := Next (Cursor); | |
4305 | ||
4306 | if Present (Fast_Element_Access_Op) and then Present (Fast_Step_Op) then | |
4307 | declare | |
b7974341 | 4308 | Curs_Name : constant Node_Id := New_Occurrence_Of (Cursor, Loc); |
02e5d0d0 | 4309 | Step_Call : Node_Id; |
4310 | ||
b7974341 | 4311 | begin |
4312 | Step_Call := | |
4313 | Make_Procedure_Call_Statement (Loc, | |
4314 | Name => | |
4315 | New_Occurrence_Of (Fast_Step_Op, Loc), | |
4316 | Parameter_Associations => New_List (Curs_Name)); | |
4317 | ||
4318 | Append_To (Stats, Step_Call); | |
4319 | Set_Assignment_OK (Curs_Name); | |
4320 | end; | |
4321 | ||
4322 | else | |
4323 | declare | |
4324 | Rhs : Node_Id; | |
4325 | ||
4326 | begin | |
4327 | Rhs := | |
4328 | Make_Function_Call (Loc, | |
4329 | Name => | |
4330 | Make_Selected_Component (Loc, | |
4331 | Prefix => New_Occurrence_Of (Iterator, Loc), | |
4332 | Selector_Name => Make_Identifier (Loc, Name_Step)), | |
4333 | Parameter_Associations => New_List ( | |
4334 | New_Occurrence_Of (Cursor, Loc))); | |
4335 | ||
4336 | Append_To (Stats, | |
4337 | Make_Assignment_Statement (Loc, | |
4338 | Name => New_Occurrence_Of (Cursor, Loc), | |
4339 | Expression => Rhs)); | |
4340 | Set_Assignment_OK (Name (Last (Stats))); | |
4341 | end; | |
4342 | end if; | |
4343 | ||
4344 | -- Generate: | |
4345 | -- while Has_Element (Cursor) loop | |
4346 | -- <Stats> | |
4347 | -- end loop; | |
4348 | ||
4349 | -- Has_Element is the second actual in the iterator package | |
4350 | ||
4351 | New_Loop := | |
4352 | Make_Loop_Statement (Loc, | |
4353 | Iteration_Scheme => | |
4354 | Make_Iteration_Scheme (Loc, | |
4355 | Condition => | |
4356 | Make_Function_Call (Loc, | |
4357 | Name => | |
02e5d0d0 | 4358 | New_Occurrence_Of |
4359 | (Next_Entity (First_Entity (Iter_Pack)), Loc), | |
4360 | Parameter_Associations => New_List ( | |
4361 | New_Occurrence_Of (Cursor, Loc)))), | |
b7974341 | 4362 | |
4363 | Statements => Stats, | |
4364 | End_Label => Empty); | |
4365 | ||
02e5d0d0 | 4366 | -- If present, preserve identifier of loop, which can be used in an exit |
4367 | -- statement in the body. | |
b7974341 | 4368 | |
4369 | if Present (Identifier (N)) then | |
4370 | Set_Identifier (New_Loop, Relocate_Node (Identifier (N))); | |
4371 | end if; | |
4372 | ||
4373 | -- Create the declarations for Iterator and cursor and insert them | |
4374 | -- before the source loop. Given that the domain of iteration is already | |
4375 | -- an entity, the iterator is just a renaming of that entity. Possible | |
4376 | -- optimization ??? | |
4377 | ||
4378 | Insert_Action (N, | |
4379 | Make_Object_Renaming_Declaration (Loc, | |
4380 | Defining_Identifier => Iterator, | |
02e5d0d0 | 4381 | Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), |
4382 | Name => Relocate_Node (Name (I_Spec)))); | |
b7974341 | 4383 | |
4384 | -- Create declaration for cursor | |
4385 | ||
4386 | declare | |
4387 | Cursor_Decl : constant Node_Id := | |
02e5d0d0 | 4388 | Make_Object_Declaration (Loc, |
4389 | Defining_Identifier => Cursor, | |
4390 | Object_Definition => | |
4391 | New_Occurrence_Of (Etype (Cursor), Loc), | |
4392 | Expression => | |
4393 | Make_Selected_Component (Loc, | |
4394 | Prefix => | |
4395 | New_Occurrence_Of (Iterator, Loc), | |
4396 | Selector_Name => | |
4397 | Make_Identifier (Loc, Name_Init))); | |
b7974341 | 4398 | |
4399 | begin | |
4400 | -- The cursor is only modified in expanded code, so it appears | |
4401 | -- as unassigned to the warning machinery. We must suppress this | |
4402 | -- spurious warning explicitly. The cursor's kind is that of the | |
4403 | -- original loop parameter (it is a constant if the domain of | |
4404 | -- iteration is constant). | |
4405 | ||
4406 | Set_Warnings_Off (Cursor); | |
4407 | Set_Assignment_OK (Cursor_Decl); | |
4408 | ||
4409 | Insert_Action (N, Cursor_Decl); | |
02e5d0d0 | 4410 | Set_Ekind (Cursor, Id_Kind); |
b7974341 | 4411 | end; |
4412 | ||
4413 | -- If the range of iteration is given by a function call that returns | |
4414 | -- a container, the finalization actions have been saved in the | |
4415 | -- Condition_Actions of the iterator. Insert them now at the head of | |
4416 | -- the loop. | |
4417 | ||
4418 | if Present (Condition_Actions (Isc)) then | |
4419 | Insert_List_Before (N, Condition_Actions (Isc)); | |
4420 | end if; | |
4421 | ||
4422 | Rewrite (N, New_Loop); | |
4423 | Analyze (N); | |
4424 | end Expand_Iterator_Loop_Over_Container; | |
4425 | ||
ee6ba406 | 4426 | ----------------------------- |
4427 | -- Expand_N_Loop_Statement -- | |
4428 | ----------------------------- | |
4429 | ||
9c486805 | 4430 | -- 1. Remove null loop entirely |
4431 | -- 2. Deal with while condition for C/Fortran boolean | |
4432 | -- 3. Deal with loops with a non-standard enumeration type range | |
4433 | -- 4. Deal with while loops where Condition_Actions is set | |
55e8372b | 4434 | -- 5. Deal with loops over predicated subtypes |
4435 | -- 6. Deal with loops with iterators over arrays and containers | |
4436 | -- 7. Insert polling call if required | |
ee6ba406 | 4437 | |
4438 | procedure Expand_N_Loop_Statement (N : Node_Id) is | |
a1fd45f3 | 4439 | Loc : constant Source_Ptr := Sloc (N); |
4440 | Scheme : constant Node_Id := Iteration_Scheme (N); | |
4441 | Stmt : Node_Id; | |
ee6ba406 | 4442 | |
4443 | begin | |
9c486805 | 4444 | -- Delete null loop |
4445 | ||
4446 | if Is_Null_Loop (N) then | |
4447 | Rewrite (N, Make_Null_Statement (Loc)); | |
4448 | return; | |
4449 | end if; | |
4450 | ||
4451 | -- Deal with condition for C/Fortran Boolean | |
4452 | ||
a1fd45f3 | 4453 | if Present (Scheme) then |
4454 | Adjust_Condition (Condition (Scheme)); | |
ee6ba406 | 4455 | end if; |
4456 | ||
9c486805 | 4457 | -- Generate polling call |
4458 | ||
ee6ba406 | 4459 | if Is_Non_Empty_List (Statements (N)) then |
4460 | Generate_Poll_Call (First (Statements (N))); | |
4461 | end if; | |
4462 | ||
0326143c | 4463 | -- Nothing more to do for plain loop with no iteration scheme |
4464 | ||
a1fd45f3 | 4465 | if No (Scheme) then |
55e8372b | 4466 | null; |
4467 | ||
d7c2851f | 4468 | -- Case of for loop (Loop_Parameter_Specification present) |
ee6ba406 | 4469 | |
36b938a3 | 4470 | -- Note: we do not have to worry about validity checking of the for loop |
0326143c | 4471 | -- range bounds here, since they were frozen with constant declarations |
4472 | -- and it is during that process that the validity checking is done. | |
4473 | ||
a1fd45f3 | 4474 | elsif Present (Loop_Parameter_Specification (Scheme)) then |
ee6ba406 | 4475 | declare |
a1fd45f3 | 4476 | LPS : constant Node_Id := |
4477 | Loop_Parameter_Specification (Scheme); | |
ee6ba406 | 4478 | Loop_Id : constant Entity_Id := Defining_Identifier (LPS); |
4479 | Ltype : constant Entity_Id := Etype (Loop_Id); | |
4480 | Btype : constant Entity_Id := Base_Type (Ltype); | |
9dfe12ae | 4481 | Expr : Node_Id; |
67e71f41 | 4482 | Decls : List_Id; |
ee6ba406 | 4483 | New_Id : Entity_Id; |
ee6ba406 | 4484 | |
4485 | begin | |
55e8372b | 4486 | -- Deal with loop over predicates |
ee6ba406 | 4487 | |
55e8372b | 4488 | if Is_Discrete_Type (Ltype) |
4489 | and then Present (Predicate_Function (Ltype)) | |
4490 | then | |
4491 | Expand_Predicated_Loop (N); | |
4492 | ||
4493 | -- Handle the case where we have a for loop with the range type | |
4494 | -- being an enumeration type with non-standard representation. | |
4495 | -- In this case we expand: | |
4496 | ||
4497 | -- for x in [reverse] a .. b loop | |
4498 | -- ... | |
4499 | -- end loop; | |
4500 | ||
4501 | -- to | |
4502 | ||
4503 | -- for xP in [reverse] integer | |
4504 | -- range etype'Pos (a) .. etype'Pos (b) | |
4505 | -- loop | |
4506 | -- declare | |
4507 | -- x : constant etype := Pos_To_Rep (xP); | |
4508 | -- begin | |
4509 | -- ... | |
4510 | -- end; | |
4511 | -- end loop; | |
4512 | ||
4513 | elsif Is_Enumeration_Type (Btype) | |
4514 | and then Present (Enum_Pos_To_Rep (Btype)) | |
4515 | then | |
4516 | New_Id := | |
4517 | Make_Defining_Identifier (Loc, | |
4518 | Chars => New_External_Name (Chars (Loop_Id), 'P')); | |
ee6ba406 | 4519 | |
55e8372b | 4520 | -- If the type has a contiguous representation, successive |
4521 | -- values can be generated as offsets from the first literal. | |
ee6ba406 | 4522 | |
55e8372b | 4523 | if Has_Contiguous_Rep (Btype) then |
4524 | Expr := | |
4525 | Unchecked_Convert_To (Btype, | |
4526 | Make_Op_Add (Loc, | |
4527 | Left_Opnd => | |
4528 | Make_Integer_Literal (Loc, | |
4529 | Enumeration_Rep (First_Literal (Btype))), | |
83c6c069 | 4530 | Right_Opnd => New_Occurrence_Of (New_Id, Loc))); |
55e8372b | 4531 | else |
4532 | -- Use the constructed array Enum_Pos_To_Rep | |
ee6ba406 | 4533 | |
55e8372b | 4534 | Expr := |
4535 | Make_Indexed_Component (Loc, | |
4536 | Prefix => | |
83c6c069 | 4537 | New_Occurrence_Of (Enum_Pos_To_Rep (Btype), Loc), |
55e8372b | 4538 | Expressions => |
83c6c069 | 4539 | New_List (New_Occurrence_Of (New_Id, Loc))); |
55e8372b | 4540 | end if; |
ee6ba406 | 4541 | |
67e71f41 | 4542 | -- Build declaration for loop identifier |
4543 | ||
4544 | Decls := | |
4545 | New_List ( | |
4546 | Make_Object_Declaration (Loc, | |
4547 | Defining_Identifier => Loop_Id, | |
4548 | Constant_Present => True, | |
83c6c069 | 4549 | Object_Definition => New_Occurrence_Of (Ltype, Loc), |
67e71f41 | 4550 | Expression => Expr)); |
4551 | ||
55e8372b | 4552 | Rewrite (N, |
4553 | Make_Loop_Statement (Loc, | |
4554 | Identifier => Identifier (N), | |
ee6ba406 | 4555 | |
55e8372b | 4556 | Iteration_Scheme => |
4557 | Make_Iteration_Scheme (Loc, | |
4558 | Loop_Parameter_Specification => | |
4559 | Make_Loop_Parameter_Specification (Loc, | |
4560 | Defining_Identifier => New_Id, | |
4561 | Reverse_Present => Reverse_Present (LPS), | |
ee6ba406 | 4562 | |
55e8372b | 4563 | Discrete_Subtype_Definition => |
4564 | Make_Subtype_Indication (Loc, | |
4565 | ||
4566 | Subtype_Mark => | |
83c6c069 | 4567 | New_Occurrence_Of (Standard_Natural, Loc), |
55e8372b | 4568 | |
4569 | Constraint => | |
4570 | Make_Range_Constraint (Loc, | |
4571 | Range_Expression => | |
4572 | Make_Range (Loc, | |
4573 | ||
4574 | Low_Bound => | |
4575 | Make_Attribute_Reference (Loc, | |
4576 | Prefix => | |
83c6c069 | 4577 | New_Occurrence_Of (Btype, Loc), |
55e8372b | 4578 | |
4579 | Attribute_Name => Name_Pos, | |
4580 | ||
4581 | Expressions => New_List ( | |
4582 | Relocate_Node | |
4583 | (Type_Low_Bound (Ltype)))), | |
4584 | ||
4585 | High_Bound => | |
4586 | Make_Attribute_Reference (Loc, | |
4587 | Prefix => | |
83c6c069 | 4588 | New_Occurrence_Of (Btype, Loc), |
55e8372b | 4589 | |
4590 | Attribute_Name => Name_Pos, | |
4591 | ||
4592 | Expressions => New_List ( | |
4593 | Relocate_Node | |
4594 | (Type_High_Bound | |
4595 | (Ltype))))))))), | |
4596 | ||
4597 | Statements => New_List ( | |
4598 | Make_Block_Statement (Loc, | |
67e71f41 | 4599 | Declarations => Decls, |
55e8372b | 4600 | Handled_Statement_Sequence => |
4601 | Make_Handled_Sequence_Of_Statements (Loc, | |
4602 | Statements => Statements (N)))), | |
4603 | ||
4604 | End_Label => End_Label (N))); | |
ca28cd49 | 4605 | |
4606 | -- The loop parameter's entity must be removed from the loop | |
67e71f41 | 4607 | -- scope's entity list and rendered invisible, since it will |
4608 | -- now be located in the new block scope. Any other entities | |
4609 | -- already associated with the loop scope, such as the loop | |
4610 | -- parameter's subtype, will remain there. | |
4611 | ||
4612 | -- In an element loop, the loop will contain a declaration for | |
4613 | -- a cursor variable; otherwise the loop id is the first entity | |
4614 | -- in the scope constructed for the loop. | |
4615 | ||
4616 | if Comes_From_Source (Loop_Id) then | |
4617 | pragma Assert (First_Entity (Scope (Loop_Id)) = Loop_Id); | |
4618 | null; | |
4619 | end if; | |
ca28cd49 | 4620 | |
ca28cd49 | 4621 | Set_First_Entity (Scope (Loop_Id), Next_Entity (Loop_Id)); |
67e71f41 | 4622 | Remove_Homonym (Loop_Id); |
3ab42ff7 | 4623 | |
ca28cd49 | 4624 | if Last_Entity (Scope (Loop_Id)) = Loop_Id then |
4625 | Set_Last_Entity (Scope (Loop_Id), Empty); | |
4626 | end if; | |
4627 | ||
55e8372b | 4628 | Analyze (N); |
ee6ba406 | 4629 | |
55e8372b | 4630 | -- Nothing to do with other cases of for loops |
ee6ba406 | 4631 | |
55e8372b | 4632 | else |
4633 | null; | |
4634 | end if; | |
ee6ba406 | 4635 | end; |
4636 | ||
21ec6442 | 4637 | -- Second case, if we have a while loop with Condition_Actions set, then |
4638 | -- we change it into a plain loop: | |
ee6ba406 | 4639 | |
4640 | -- while C loop | |
4641 | -- ... | |
4642 | -- end loop; | |
4643 | ||
4644 | -- changed to: | |
4645 | ||
4646 | -- loop | |
4647 | -- <<condition actions>> | |
4648 | -- exit when not C; | |
4649 | -- ... | |
4650 | -- end loop | |
4651 | ||
a1fd45f3 | 4652 | elsif Present (Scheme) |
4653 | and then Present (Condition_Actions (Scheme)) | |
4654 | and then Present (Condition (Scheme)) | |
ee6ba406 | 4655 | then |
4656 | declare | |
4657 | ES : Node_Id; | |
4658 | ||
4659 | begin | |
4660 | ES := | |
a1fd45f3 | 4661 | Make_Exit_Statement (Sloc (Condition (Scheme)), |
ee6ba406 | 4662 | Condition => |
a1fd45f3 | 4663 | Make_Op_Not (Sloc (Condition (Scheme)), |
4664 | Right_Opnd => Condition (Scheme))); | |
ee6ba406 | 4665 | |
4666 | Prepend (ES, Statements (N)); | |
a1fd45f3 | 4667 | Insert_List_Before (ES, Condition_Actions (Scheme)); |
ee6ba406 | 4668 | |
21ec6442 | 4669 | -- This is not an implicit loop, since it is generated in response |
4670 | -- to the loop statement being processed. If this is itself | |
4671 | -- implicit, the restriction has already been checked. If not, | |
4672 | -- it is an explicit loop. | |
ee6ba406 | 4673 | |
4674 | Rewrite (N, | |
4675 | Make_Loop_Statement (Sloc (N), | |
4676 | Identifier => Identifier (N), | |
4677 | Statements => Statements (N), | |
4678 | End_Label => End_Label (N))); | |
4679 | ||
4680 | Analyze (N); | |
4681 | end; | |
f37e6e70 | 4682 | |
55e8372b | 4683 | -- Here to deal with iterator case |
4684 | ||
a1fd45f3 | 4685 | elsif Present (Scheme) |
4686 | and then Present (Iterator_Specification (Scheme)) | |
f37e6e70 | 4687 | then |
4688 | Expand_Iterator_Loop (N); | |
877e0ffc | 4689 | |
4690 | -- An iterator loop may generate renaming declarations for elements | |
4691 | -- that require debug information. This is the case in particular | |
4692 | -- with element iterators, where debug information must be generated | |
4693 | -- for the temporary that holds the element value. These temporaries | |
4694 | -- are created within a transient block whose local declarations are | |
15487398 | 4695 | -- transferred to the loop, which now has nontrivial local objects. |
877e0ffc | 4696 | |
4697 | if Nkind (N) = N_Loop_Statement | |
4698 | and then Present (Identifier (N)) | |
4699 | then | |
4700 | Qualify_Entity_Names (N); | |
4701 | end if; | |
ee6ba406 | 4702 | end if; |
f6aa36b9 | 4703 | |
a1fd45f3 | 4704 | -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop |
4705 | -- is transformed into a conditional block where the original loop is | |
4706 | -- the sole statement. Inspect the statements of the nested loop for | |
4707 | -- controlled objects. | |
4708 | ||
4709 | Stmt := N; | |
f6aa36b9 | 4710 | |
a1fd45f3 | 4711 | if Subject_To_Loop_Entry_Attributes (Stmt) then |
4712 | Stmt := Find_Loop_In_Conditional_Block (Stmt); | |
f6aa36b9 | 4713 | end if; |
a1fd45f3 | 4714 | |
4715 | Process_Statements_For_Controlled_Objects (Stmt); | |
ee6ba406 | 4716 | end Expand_N_Loop_Statement; |
4717 | ||
55e8372b | 4718 | ---------------------------- |
4719 | -- Expand_Predicated_Loop -- | |
4720 | ---------------------------- | |
4721 | ||
4722 | -- Note: the expander can handle generation of loops over predicated | |
4723 | -- subtypes for both the dynamic and static cases. Depending on what | |
6fb3c314 | 4724 | -- we decide is allowed in Ada 2012 mode and/or extensions allowed |
55e8372b | 4725 | -- mode, the semantic analyzer may disallow one or both forms. |
4726 | ||
4727 | procedure Expand_Predicated_Loop (N : Node_Id) is | |
4728 | Loc : constant Source_Ptr := Sloc (N); | |
4729 | Isc : constant Node_Id := Iteration_Scheme (N); | |
4730 | LPS : constant Node_Id := Loop_Parameter_Specification (Isc); | |
4731 | Loop_Id : constant Entity_Id := Defining_Identifier (LPS); | |
4732 | Ltype : constant Entity_Id := Etype (Loop_Id); | |
5c6a5792 | 4733 | Stat : constant List_Id := Static_Discrete_Predicate (Ltype); |
55e8372b | 4734 | Stmts : constant List_Id := Statements (N); |
4735 | ||
4736 | begin | |
d7c2851f | 4737 | -- Case of iteration over non-static predicate, should not be possible |
4738 | -- since this is not allowed by the semantics and should have been | |
4739 | -- caught during analysis of the loop statement. | |
55e8372b | 4740 | |
4741 | if No (Stat) then | |
d7c2851f | 4742 | raise Program_Error; |
55e8372b | 4743 | |
d7c2851f | 4744 | -- If the predicate list is empty, that corresponds to a predicate of |
4745 | -- False, in which case the loop won't run at all, and we rewrite the | |
4746 | -- entire loop as a null statement. | |
55e8372b | 4747 | |
d7c2851f | 4748 | elsif Is_Empty_List (Stat) then |
4749 | Rewrite (N, Make_Null_Statement (Loc)); | |
4750 | Analyze (N); | |
55e8372b | 4751 | |
4752 | -- For expansion over a static predicate we generate the following | |
4753 | ||
4754 | -- declare | |
4755 | -- J : Ltype := min-val; | |
4756 | -- begin | |
4757 | -- loop | |
4758 | -- body | |
4759 | -- case J is | |
4760 | -- when endpoint => J := startpoint; | |
4761 | -- when endpoint => J := startpoint; | |
4762 | -- ... | |
4763 | -- when max-val => exit; | |
4764 | -- when others => J := Lval'Succ (J); | |
4765 | -- end case; | |
4766 | -- end loop; | |
4767 | -- end; | |
4768 | ||
6fe98650 | 4769 | -- with min-val replaced by max-val and Succ replaced by Pred if the |
4770 | -- loop parameter specification carries a Reverse indicator. | |
4771 | ||
55e8372b | 4772 | -- To make this a little clearer, let's take a specific example: |
4773 | ||
4774 | -- type Int is range 1 .. 10; | |
6fe98650 | 4775 | -- subtype StaticP is Int with |
4776 | -- predicate => StaticP in 3 | 10 | 5 .. 7; | |
55e8372b | 4777 | -- ... |
4778 | -- for L in StaticP loop | |
4779 | -- Put_Line ("static:" & J'Img); | |
4780 | -- end loop; | |
4781 | ||
4782 | -- In this case, the loop is transformed into | |
4783 | ||
4784 | -- begin | |
4785 | -- J : L := 3; | |
4786 | -- loop | |
4787 | -- body | |
4788 | -- case J is | |
4789 | -- when 3 => J := 5; | |
4790 | -- when 7 => J := 10; | |
4791 | -- when 10 => exit; | |
4792 | -- when others => J := L'Succ (J); | |
4793 | -- end case; | |
4794 | -- end loop; | |
4795 | -- end; | |
4796 | ||
fcdcccb9 | 4797 | -- In addition, if the loop specification is given by a subtype |
4798 | -- indication that constrains a predicated type, the bounds of | |
4799 | -- iteration are given by those of the subtype indication. | |
4800 | ||
55e8372b | 4801 | else |
4802 | Static_Predicate : declare | |
4803 | S : Node_Id; | |
4804 | D : Node_Id; | |
4805 | P : Node_Id; | |
4806 | Alts : List_Id; | |
4807 | Cstm : Node_Id; | |
4808 | ||
fcdcccb9 | 4809 | -- If the domain is an itype, note the bounds of its range. |
4810 | ||
5bb74b99 | 4811 | L_Hi : Node_Id := Empty; |
4812 | L_Lo : Node_Id := Empty; | |
fcdcccb9 | 4813 | |
55e8372b | 4814 | function Lo_Val (N : Node_Id) return Node_Id; |
4815 | -- Given static expression or static range, returns an identifier | |
4816 | -- whose value is the low bound of the expression value or range. | |
4817 | ||
4818 | function Hi_Val (N : Node_Id) return Node_Id; | |
4819 | -- Given static expression or static range, returns an identifier | |
4820 | -- whose value is the high bound of the expression value or range. | |
4821 | ||
4822 | ------------ | |
4823 | -- Hi_Val -- | |
4824 | ------------ | |
4825 | ||
4826 | function Hi_Val (N : Node_Id) return Node_Id is | |
4827 | begin | |
cda40848 | 4828 | if Is_OK_Static_Expression (N) then |
55e8372b | 4829 | return New_Copy (N); |
4830 | else | |
4831 | pragma Assert (Nkind (N) = N_Range); | |
4832 | return New_Copy (High_Bound (N)); | |
4833 | end if; | |
4834 | end Hi_Val; | |
4835 | ||
4836 | ------------ | |
4837 | -- Lo_Val -- | |
4838 | ------------ | |
4839 | ||
4840 | function Lo_Val (N : Node_Id) return Node_Id is | |
4841 | begin | |
cda40848 | 4842 | if Is_OK_Static_Expression (N) then |
55e8372b | 4843 | return New_Copy (N); |
4844 | else | |
4845 | pragma Assert (Nkind (N) = N_Range); | |
4846 | return New_Copy (Low_Bound (N)); | |
4847 | end if; | |
4848 | end Lo_Val; | |
4849 | ||
4850 | -- Start of processing for Static_Predicate | |
4851 | ||
4852 | begin | |
4853 | -- Convert loop identifier to normal variable and reanalyze it so | |
4854 | -- that this conversion works. We have to use the same defining | |
4855 | -- identifier, since there may be references in the loop body. | |
4856 | ||
4857 | Set_Analyzed (Loop_Id, False); | |
4858 | Set_Ekind (Loop_Id, E_Variable); | |
4859 | ||
1b24a6cb | 4860 | -- In most loops the loop variable is assigned in various |
4861 | -- alternatives in the body. However, in the rare case when | |
4862 | -- the range specifies a single element, the loop variable | |
4863 | -- may trigger a spurious warning that is could be constant. | |
4864 | -- This warning might as well be suppressed. | |
4865 | ||
4866 | Set_Warnings_Off (Loop_Id); | |
4867 | ||
fcdcccb9 | 4868 | if Is_Itype (Ltype) then |
4869 | L_Hi := High_Bound (Scalar_Range (Ltype)); | |
4870 | L_Lo := Low_Bound (Scalar_Range (Ltype)); | |
4871 | end if; | |
4872 | ||
55e8372b | 4873 | -- Loop to create branches of case statement |
4874 | ||
4875 | Alts := New_List; | |
55e8372b | 4876 | |
6fe98650 | 4877 | if Reverse_Present (LPS) then |
55e8372b | 4878 | |
6fe98650 | 4879 | -- Initial value is largest value in predicate. |
4880 | ||
fcdcccb9 | 4881 | if Is_Itype (Ltype) then |
4882 | D := | |
4883 | Make_Object_Declaration (Loc, | |
4884 | Defining_Identifier => Loop_Id, | |
4885 | Object_Definition => New_Occurrence_Of (Ltype, Loc), | |
4886 | Expression => L_Hi); | |
4887 | ||
4888 | else | |
4889 | D := | |
4890 | Make_Object_Declaration (Loc, | |
4891 | Defining_Identifier => Loop_Id, | |
4892 | Object_Definition => New_Occurrence_Of (Ltype, Loc), | |
4893 | Expression => Hi_Val (Last (Stat))); | |
4894 | end if; | |
6fe98650 | 4895 | |
4896 | P := Last (Stat); | |
4897 | while Present (P) loop | |
4898 | if No (Prev (P)) then | |
4899 | S := Make_Exit_Statement (Loc); | |
4900 | else | |
4901 | S := | |
4902 | Make_Assignment_Statement (Loc, | |
4903 | Name => New_Occurrence_Of (Loop_Id, Loc), | |
4904 | Expression => Hi_Val (Prev (P))); | |
4905 | Set_Suppress_Assignment_Checks (S); | |
4906 | end if; | |
4907 | ||
4908 | Append_To (Alts, | |
4909 | Make_Case_Statement_Alternative (Loc, | |
4910 | Statements => New_List (S), | |
4911 | Discrete_Choices => New_List (Lo_Val (P)))); | |
4912 | ||
4913 | Prev (P); | |
4914 | end loop; | |
4915 | ||
fcdcccb9 | 4916 | if Is_Itype (Ltype) |
4917 | and then Is_OK_Static_Expression (L_Lo) | |
4918 | and then | |
4919 | Expr_Value (L_Lo) /= Expr_Value (Lo_Val (First (Stat))) | |
4920 | then | |
4921 | Append_To (Alts, | |
4922 | Make_Case_Statement_Alternative (Loc, | |
4923 | Statements => New_List (Make_Exit_Statement (Loc)), | |
4924 | Discrete_Choices => New_List (L_Lo))); | |
4925 | end if; | |
4926 | ||
6fe98650 | 4927 | else |
8b3a98b2 | 4928 | -- Initial value is smallest value in predicate |
6fe98650 | 4929 | |
fcdcccb9 | 4930 | if Is_Itype (Ltype) then |
4931 | D := | |
4932 | Make_Object_Declaration (Loc, | |
4933 | Defining_Identifier => Loop_Id, | |
4934 | Object_Definition => New_Occurrence_Of (Ltype, Loc), | |
4935 | Expression => L_Lo); | |
4936 | else | |
4937 | D := | |
4938 | Make_Object_Declaration (Loc, | |
4939 | Defining_Identifier => Loop_Id, | |
4940 | Object_Definition => New_Occurrence_Of (Ltype, Loc), | |
4941 | Expression => Lo_Val (First (Stat))); | |
4942 | end if; | |
6fe98650 | 4943 | |
4944 | P := First (Stat); | |
4945 | while Present (P) loop | |
4946 | if No (Next (P)) then | |
4947 | S := Make_Exit_Statement (Loc); | |
4948 | else | |
4949 | S := | |
4950 | Make_Assignment_Statement (Loc, | |
4951 | Name => New_Occurrence_Of (Loop_Id, Loc), | |
4952 | Expression => Lo_Val (Next (P))); | |
4953 | Set_Suppress_Assignment_Checks (S); | |
4954 | end if; | |
4955 | ||
4956 | Append_To (Alts, | |
4957 | Make_Case_Statement_Alternative (Loc, | |
4958 | Statements => New_List (S), | |
4959 | Discrete_Choices => New_List (Hi_Val (P)))); | |
4960 | ||
4961 | Next (P); | |
4962 | end loop; | |
fcdcccb9 | 4963 | |
4964 | if Is_Itype (Ltype) | |
4965 | and then Is_OK_Static_Expression (L_Hi) | |
4966 | and then | |
4967 | Expr_Value (L_Hi) /= Expr_Value (Lo_Val (Last (Stat))) | |
4968 | then | |
4969 | Append_To (Alts, | |
4970 | Make_Case_Statement_Alternative (Loc, | |
4971 | Statements => New_List (Make_Exit_Statement (Loc)), | |
4972 | Discrete_Choices => New_List (L_Hi))); | |
4973 | end if; | |
6fe98650 | 4974 | end if; |
55e8372b | 4975 | |
4976 | -- Add others choice | |
4977 | ||
6fe98650 | 4978 | declare |
4979 | Name_Next : Name_Id; | |
4980 | ||
4981 | begin | |
4982 | if Reverse_Present (LPS) then | |
4983 | Name_Next := Name_Pred; | |
4984 | else | |
4985 | Name_Next := Name_Succ; | |
4986 | end if; | |
4987 | ||
4988 | S := | |
8b3a98b2 | 4989 | Make_Assignment_Statement (Loc, |
4990 | Name => New_Occurrence_Of (Loop_Id, Loc), | |
4991 | Expression => | |
4992 | Make_Attribute_Reference (Loc, | |
4993 | Prefix => New_Occurrence_Of (Ltype, Loc), | |
4994 | Attribute_Name => Name_Next, | |
4995 | Expressions => New_List ( | |
4996 | New_Occurrence_Of (Loop_Id, Loc)))); | |
6fe98650 | 4997 | Set_Suppress_Assignment_Checks (S); |
4998 | end; | |
55e8372b | 4999 | |
5000 | Append_To (Alts, | |
5001 | Make_Case_Statement_Alternative (Loc, | |
5002 | Discrete_Choices => New_List (Make_Others_Choice (Loc)), | |
5003 | Statements => New_List (S))); | |
5004 | ||
5005 | -- Construct case statement and append to body statements | |
5006 | ||
5007 | Cstm := | |
5008 | Make_Case_Statement (Loc, | |
5009 | Expression => New_Occurrence_Of (Loop_Id, Loc), | |
5010 | Alternatives => Alts); | |
5011 | Append_To (Stmts, Cstm); | |
5012 | ||
5013 | -- Rewrite the loop | |
5014 | ||
55e8372b | 5015 | Set_Suppress_Assignment_Checks (D); |
5016 | ||
5017 | Rewrite (N, | |
5018 | Make_Block_Statement (Loc, | |
5019 | Declarations => New_List (D), | |
5020 | Handled_Statement_Sequence => | |
5021 | Make_Handled_Sequence_Of_Statements (Loc, | |
5022 | Statements => New_List ( | |
5023 | Make_Loop_Statement (Loc, | |
5024 | Statements => Stmts, | |
5025 | End_Label => Empty))))); | |
5026 | ||
5027 | Analyze (N); | |
5028 | end Static_Predicate; | |
5029 | end if; | |
5030 | end Expand_Predicated_Loop; | |
5031 | ||
0326143c | 5032 | ------------------------------ |
5033 | -- Make_Tag_Ctrl_Assignment -- | |
5034 | ------------------------------ | |
5035 | ||
5036 | function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is | |
bb3b440a | 5037 | Asn : constant Node_Id := Relocate_Node (N); |
0326143c | 5038 | L : constant Node_Id := Name (N); |
bb3b440a | 5039 | Loc : constant Source_Ptr := Sloc (N); |
5040 | Res : constant List_Id := New_List; | |
0326143c | 5041 | T : constant Entity_Id := Underlying_Type (Etype (L)); |
5042 | ||
bb3b440a | 5043 | Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T); |
45851103 | 5044 | Ctrl_Act : constant Boolean := Needs_Finalization (T) |
0326143c | 5045 | and then not No_Ctrl_Actions (N); |
0326143c | 5046 | Save_Tag : constant Boolean := Is_Tagged_Type (T) |
bb3b440a | 5047 | and then not Comp_Asn |
0326143c | 5048 | and then not No_Ctrl_Actions (N) |
662256db | 5049 | and then Tagged_Type_Expansion; |
fe696bd7 | 5050 | Adj_Call : Node_Id; |
5051 | Fin_Call : Node_Id; | |
5052 | Tag_Id : Entity_Id; | |
0326143c | 5053 | |
5054 | begin | |
d2b860b4 | 5055 | -- Finalize the target of the assignment when controlled |
5056 | ||
0326143c | 5057 | -- We have two exceptions here: |
5058 | ||
d2b860b4 | 5059 | -- 1. If we are in an init proc since it is an initialization more |
5060 | -- than an assignment. | |
0326143c | 5061 | |
5062 | -- 2. If the left-hand side is a temporary that was not initialized | |
5063 | -- (or the parent part of a temporary since it is the case in | |
5064 | -- extension aggregates). Such a temporary does not come from | |
5065 | -- source. We must examine the original node for the prefix, because | |
5066 | -- it may be a component of an entry formal, in which case it has | |
5067 | -- been rewritten and does not appear to come from source either. | |
5068 | ||
5069 | -- Case of init proc | |
5070 | ||
5071 | if not Ctrl_Act then | |
5072 | null; | |
5073 | ||
7748ccb2 | 5074 | -- The left-hand side is an uninitialized temporary object |
0326143c | 5075 | |
5076 | elsif Nkind (L) = N_Type_Conversion | |
5077 | and then Is_Entity_Name (Expression (L)) | |
d2b860b4 | 5078 | and then Nkind (Parent (Entity (Expression (L)))) = |
5079 | N_Object_Declaration | |
0326143c | 5080 | and then No_Initialization (Parent (Entity (Expression (L)))) |
5081 | then | |
5082 | null; | |
4644a919 | 5083 | |
0326143c | 5084 | else |
fe696bd7 | 5085 | Fin_Call := |
b3190af0 | 5086 | Make_Final_Call |
5087 | (Obj_Ref => Duplicate_Subexpr_No_Checks (L), | |
fe696bd7 | 5088 | Typ => Etype (L)); |
5089 | ||
5090 | if Present (Fin_Call) then | |
5091 | Append_To (Res, Fin_Call); | |
5092 | end if; | |
0326143c | 5093 | end if; |
5094 | ||
4169cf0d | 5095 | -- Save the Tag in a local variable Tag_Id |
0326143c | 5096 | |
5097 | if Save_Tag then | |
4169cf0d | 5098 | Tag_Id := Make_Temporary (Loc, 'A'); |
0326143c | 5099 | |
5100 | Append_To (Res, | |
5101 | Make_Object_Declaration (Loc, | |
4169cf0d | 5102 | Defining_Identifier => Tag_Id, |
83c6c069 | 5103 | Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), |
b3190af0 | 5104 | Expression => |
0326143c | 5105 | Make_Selected_Component (Loc, |
b3190af0 | 5106 | Prefix => Duplicate_Subexpr_No_Checks (L), |
bb3b440a | 5107 | Selector_Name => |
83c6c069 | 5108 | New_Occurrence_Of (First_Tag_Component (T), Loc)))); |
0326143c | 5109 | |
4169cf0d | 5110 | -- Otherwise Tag_Id is not used |
0326143c | 5111 | |
5112 | else | |
4169cf0d | 5113 | Tag_Id := Empty; |
5114 | end if; | |
5115 | ||
bb3b440a | 5116 | -- If the tagged type has a full rep clause, expand the assignment into |
5117 | -- component-wise assignments. Mark the node as unanalyzed in order to | |
5118 | -- generate the proper code and propagate this scenario by setting a | |
5119 | -- flag to avoid infinite recursion. | |
0326143c | 5120 | |
bb3b440a | 5121 | if Comp_Asn then |
5122 | Set_Analyzed (Asn, False); | |
5123 | Set_Componentwise_Assignment (Asn, True); | |
8f71d067 | 5124 | end if; |
ee6ba406 | 5125 | |
bb3b440a | 5126 | Append_To (Res, Asn); |
5127 | ||
00f91aef | 5128 | -- Restore the tag |
ee6ba406 | 5129 | |
5130 | if Save_Tag then | |
5131 | Append_To (Res, | |
5132 | Make_Assignment_Statement (Loc, | |
b3190af0 | 5133 | Name => |
ee6ba406 | 5134 | Make_Selected_Component (Loc, |
b3190af0 | 5135 | Prefix => Duplicate_Subexpr_No_Checks (L), |
4169cf0d | 5136 | Selector_Name => |
83c6c069 | 5137 | New_Occurrence_Of (First_Tag_Component (T), Loc)), |
5138 | Expression => New_Occurrence_Of (Tag_Id, Loc))); | |
4169cf0d | 5139 | end if; |
5140 | ||
bb3b440a | 5141 | -- Adjust the target after the assignment when controlled (not in the |
5142 | -- init proc since it is an initialization more than an assignment). | |
0524b5dd | 5143 | |
bb3b440a | 5144 | if Ctrl_Act then |
fe696bd7 | 5145 | Adj_Call := |
b3190af0 | 5146 | Make_Adjust_Call |
5147 | (Obj_Ref => Duplicate_Subexpr_Move_Checks (L), | |
fe696bd7 | 5148 | Typ => Etype (L)); |
5149 | ||
5150 | if Present (Adj_Call) then | |
5151 | Append_To (Res, Adj_Call); | |
5152 | end if; | |
ee6ba406 | 5153 | end if; |
5154 | ||
5155 | return Res; | |
9dfe12ae | 5156 | |
5157 | exception | |
b3190af0 | 5158 | |
8f71d067 | 5159 | -- Could use comment here ??? |
5160 | ||
9dfe12ae | 5161 | when RE_Not_Available => |
5162 | return Empty_List; | |
ee6ba406 | 5163 | end Make_Tag_Ctrl_Assignment; |
5164 | ||
5165 | end Exp_Ch5; |