]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C H 5 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
57a8057a | 26 | with Aspects; use Aspects; |
996ae0b0 RK |
27 | with Atree; use Atree; |
28 | with Checks; use Checks; | |
29 | with Einfo; use Einfo; | |
30 | with Errout; use Errout; | |
31 | with Expander; use Expander; | |
0613fb33 | 32 | with Exp_Ch6; use Exp_Ch6; |
996ae0b0 RK |
33 | with Exp_Util; use Exp_Util; |
34 | with Freeze; use Freeze; | |
8636f52f | 35 | with Ghost; use Ghost; |
2a806772 | 36 | with Lib; use Lib; |
996ae0b0 | 37 | with Lib.Xref; use Lib.Xref; |
27c489df | 38 | with Namet; use Namet; |
996ae0b0 | 39 | with Nlists; use Nlists; |
9596236a | 40 | with Nmake; use Nmake; |
996ae0b0 RK |
41 | with Opt; use Opt; |
42 | with Sem; use Sem; | |
a4100e55 | 43 | with Sem_Aux; use Sem_Aux; |
996ae0b0 RK |
44 | with Sem_Case; use Sem_Case; |
45 | with Sem_Ch3; use Sem_Ch3; | |
0613fb33 | 46 | with Sem_Ch6; use Sem_Ch6; |
996ae0b0 | 47 | with Sem_Ch8; use Sem_Ch8; |
dec6faf1 | 48 | with Sem_Dim; use Sem_Dim; |
996ae0b0 | 49 | with Sem_Disp; use Sem_Disp; |
2a806772 | 50 | with Sem_Elab; use Sem_Elab; |
996ae0b0 RK |
51 | with Sem_Eval; use Sem_Eval; |
52 | with Sem_Res; use Sem_Res; | |
53 | with Sem_Type; use Sem_Type; | |
54 | with Sem_Util; use Sem_Util; | |
55 | with Sem_Warn; use Sem_Warn; | |
2a806772 | 56 | with Snames; use Snames; |
996ae0b0 RK |
57 | with Stand; use Stand; |
58 | with Sinfo; use Sinfo; | |
fbf5a39b | 59 | with Targparm; use Targparm; |
996ae0b0 RK |
60 | with Tbuild; use Tbuild; |
61 | with Uintp; use Uintp; | |
62 | ||
63 | package body Sem_Ch5 is | |
64 | ||
f8a21934 AC |
65 | Current_Assignment : Node_Id := Empty; |
66 | -- This variable holds the node for an assignment that contains target | |
67 | -- names. The corresponding flag has been set by the parser, and when | |
68 | -- set the analysis of the RHS must be done with all expansion disabled, | |
69 | -- because the assignment is reanalyzed after expansion has replaced all | |
70 | -- occurrences of the target name appropriately. | |
ae33543c | 71 | |
996ae0b0 | 72 | Unblocked_Exit_Count : Nat := 0; |
6f21ed26 | 73 | -- This variable is used when processing if statements, case statements, |
27c489df RD |
74 | -- and block statements. It counts the number of exit points that are not |
75 | -- blocked by unconditional transfer instructions: for IF and CASE, these | |
76 | -- are the branches of the conditional; for a block, they are the statement | |
77 | -- sequence of the block, and the statement sequences of any exception | |
78 | -- handlers that are part of the block. When processing is complete, if | |
79 | -- this count is zero, it means that control cannot fall through the IF, | |
80 | -- CASE or block statement. This is used for the generation of warning | |
81 | -- messages. This variable is recursively saved on entry to processing the | |
82 | -- construct, and restored on exit. | |
996ae0b0 | 83 | |
abbfd698 | 84 | function Has_Sec_Stack_Call (N : Node_Id) return Boolean; |
e8427749 JM |
85 | -- N is the node for an arbitrary construct. This function searches the |
86 | -- construct N to see if any expressions within it contain function | |
87 | -- calls that use the secondary stack, returning True if any such call | |
88 | -- is found, and False otherwise. | |
89 | ||
804670f1 | 90 | procedure Preanalyze_Range (R_Copy : Node_Id); |
ef992452 AC |
91 | -- Determine expected type of range or domain of iteration of Ada 2012 |
92 | -- loop by analyzing separate copy. Do the analysis and resolution of the | |
93 | -- copy of the bound(s) with expansion disabled, to prevent the generation | |
94 | -- of finalization actions. This prevents memory leaks when the bounds | |
95 | -- contain calls to functions returning controlled arrays or when the | |
96 | -- domain of iteration is a container. | |
97 | ||
996ae0b0 RK |
98 | ------------------------ |
99 | -- Analyze_Assignment -- | |
100 | ------------------------ | |
101 | ||
b0bf18ad AC |
102 | -- WARNING: This routine manages Ghost regions. Return statements must be |
103 | -- replaced by gotos which jump to the end of the routine and restore the | |
104 | -- Ghost mode. | |
105 | ||
996ae0b0 | 106 | procedure Analyze_Assignment (N : Node_Id) is |
b6e6a4e3 | 107 | Lhs : constant Node_Id := Name (N); |
5168a9b3 | 108 | Rhs : Node_Id := Expression (N); |
996ae0b0 RK |
109 | |
110 | procedure Diagnose_Non_Variable_Lhs (N : Node_Id); | |
59f3dd0a AC |
111 | -- N is the node for the left hand side of an assignment, and it is not |
112 | -- a variable. This routine issues an appropriate diagnostic. | |
996ae0b0 | 113 | |
5efc1c00 HK |
114 | function Is_Protected_Part_Of_Constituent |
115 | (Nod : Node_Id) return Boolean; | |
116 | -- Determine whether arbitrary node Nod denotes a Part_Of constituent of | |
117 | -- a single protected type. | |
118 | ||
c8ef728f ES |
119 | procedure Kill_Lhs; |
120 | -- This is called to kill current value settings of a simple variable | |
121 | -- on the left hand side. We call it if we find any error in analyzing | |
122 | -- the assignment, and at the end of processing before setting any new | |
123 | -- current values in place. | |
124 | ||
996ae0b0 RK |
125 | procedure Set_Assignment_Type |
126 | (Opnd : Node_Id; | |
127 | Opnd_Type : in out Entity_Id); | |
176dadf6 AC |
128 | -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the |
129 | -- nominal subtype. This procedure is used to deal with cases where the | |
130 | -- nominal subtype must be replaced by the actual subtype. | |
996ae0b0 | 131 | |
5168a9b3 PMR |
132 | procedure Transform_BIP_Assignment (Typ : Entity_Id); |
133 | function Should_Transform_BIP_Assignment | |
134 | (Typ : Entity_Id) return Boolean; | |
135 | -- If the right-hand side of an assignment statement is a build-in-place | |
136 | -- call we cannot build in place, so we insert a temp initialized with | |
137 | -- the call, and transform the assignment statement to copy the temp. | |
138 | -- Transform_BIP_Assignment does the tranformation, and | |
139 | -- Should_Transform_BIP_Assignment determines whether we should. | |
140 | -- The same goes for qualified expressions and conversions whose | |
141 | -- operand is such a call. | |
142 | -- | |
143 | -- This is only for nonlimited types; assignment statements are illegal | |
144 | -- for limited types, but are generated internally for aggregates and | |
145 | -- init procs. These limited-type are not really assignment statements | |
146 | -- -- conceptually, they are initializations, so should not be | |
147 | -- transformed. | |
148 | -- | |
149 | -- Similarly, for nonlimited types, aggregates and init procs generate | |
150 | -- assignment statements that are really initializations. These are | |
151 | -- marked No_Ctrl_Actions. | |
152 | ||
5efc1c00 HK |
153 | function Within_Function return Boolean; |
154 | -- Determine whether the current scope is a function or appears within | |
155 | -- one. | |
156 | ||
996ae0b0 RK |
157 | ------------------------------- |
158 | -- Diagnose_Non_Variable_Lhs -- | |
159 | ------------------------------- | |
160 | ||
161 | procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is | |
162 | begin | |
176dadf6 AC |
163 | -- Not worth posting another error if left hand side already flagged |
164 | -- as being illegal in some respect. | |
996ae0b0 RK |
165 | |
166 | if Error_Posted (N) then | |
167 | return; | |
168 | ||
169 | -- Some special bad cases of entity names | |
170 | ||
171 | elsif Is_Entity_Name (N) then | |
45fc7ddb HK |
172 | declare |
173 | Ent : constant Entity_Id := Entity (N); | |
996ae0b0 | 174 | |
45fc7ddb | 175 | begin |
5a0c86bd BD |
176 | if Ekind (Ent) = E_Loop_Parameter |
177 | or else Is_Loop_Parameter (Ent) | |
178 | then | |
179 | Error_Msg_N ("assignment to loop parameter not allowed", N); | |
180 | return; | |
181 | ||
182 | elsif Ekind (Ent) = E_In_Parameter then | |
45fc7ddb HK |
183 | Error_Msg_N |
184 | ("assignment to IN mode parameter not allowed", N); | |
7b27e183 | 185 | return; |
45fc7ddb HK |
186 | |
187 | -- Renamings of protected private components are turned into | |
188 | -- constants when compiling a protected function. In the case | |
189 | -- of single protected types, the private component appears | |
190 | -- directly. | |
191 | ||
5efc1c00 | 192 | elsif (Is_Prival (Ent) and then Within_Function) |
45fc7ddb HK |
193 | or else |
194 | (Ekind (Ent) = E_Component | |
ac7d724d | 195 | and then Is_Protected_Type (Scope (Ent))) |
45fc7ddb HK |
196 | then |
197 | Error_Msg_N | |
198 | ("protected function cannot modify protected object", N); | |
7b27e183 | 199 | return; |
45fc7ddb HK |
200 | end if; |
201 | end; | |
996ae0b0 | 202 | |
7b27e183 AC |
203 | -- For indexed components, test prefix if it is in array. We do not |
204 | -- want to recurse for cases where the prefix is a pointer, since we | |
205 | -- may get a message confusing the pointer and what it references. | |
996ae0b0 | 206 | |
7b27e183 AC |
207 | elsif Nkind (N) = N_Indexed_Component |
208 | and then Is_Array_Type (Etype (Prefix (N))) | |
209 | then | |
996ae0b0 | 210 | Diagnose_Non_Variable_Lhs (Prefix (N)); |
7b27e183 | 211 | return; |
996ae0b0 | 212 | |
e2d6a9e5 | 213 | -- Another special case for assignment to discriminant |
08aa9a4a AC |
214 | |
215 | elsif Nkind (N) = N_Selected_Component then | |
216 | if Present (Entity (Selector_Name (N))) | |
217 | and then Ekind (Entity (Selector_Name (N))) = E_Discriminant | |
218 | then | |
7b27e183 AC |
219 | Error_Msg_N ("assignment to discriminant not allowed", N); |
220 | return; | |
221 | ||
222 | -- For selection from record, diagnose prefix, but note that again | |
223 | -- we only do this for a record, not e.g. for a pointer. | |
224 | ||
225 | elsif Is_Record_Type (Etype (Prefix (N))) then | |
08aa9a4a | 226 | Diagnose_Non_Variable_Lhs (Prefix (N)); |
7b27e183 | 227 | return; |
08aa9a4a | 228 | end if; |
7b27e183 | 229 | end if; |
08aa9a4a | 230 | |
7b27e183 | 231 | -- If we fall through, we have no special message to issue |
996ae0b0 | 232 | |
7b27e183 | 233 | Error_Msg_N ("left hand side of assignment must be a variable", N); |
996ae0b0 RK |
234 | end Diagnose_Non_Variable_Lhs; |
235 | ||
5efc1c00 HK |
236 | -------------------------------------- |
237 | -- Is_Protected_Part_Of_Constituent -- | |
238 | -------------------------------------- | |
239 | ||
240 | function Is_Protected_Part_Of_Constituent | |
241 | (Nod : Node_Id) return Boolean | |
242 | is | |
243 | Encap_Id : Entity_Id; | |
244 | Var_Id : Entity_Id; | |
245 | ||
246 | begin | |
247 | -- Abstract states and variables may act as Part_Of constituents of | |
248 | -- single protected types, however only variables can be modified by | |
249 | -- an assignment. | |
250 | ||
251 | if Is_Entity_Name (Nod) then | |
252 | Var_Id := Entity (Nod); | |
253 | ||
254 | if Present (Var_Id) and then Ekind (Var_Id) = E_Variable then | |
255 | Encap_Id := Encapsulating_State (Var_Id); | |
256 | ||
257 | -- To qualify, the node must denote a reference to a variable | |
258 | -- whose encapsulating state is a single protected object. | |
259 | ||
260 | return | |
261 | Present (Encap_Id) | |
262 | and then Is_Single_Protected_Object (Encap_Id); | |
263 | end if; | |
264 | end if; | |
265 | ||
266 | return False; | |
267 | end Is_Protected_Part_Of_Constituent; | |
268 | ||
c8ef728f | 269 | -------------- |
5ff90f08 | 270 | -- Kill_Lhs -- |
c8ef728f ES |
271 | -------------- |
272 | ||
273 | procedure Kill_Lhs is | |
274 | begin | |
275 | if Is_Entity_Name (Lhs) then | |
276 | declare | |
277 | Ent : constant Entity_Id := Entity (Lhs); | |
278 | begin | |
279 | if Present (Ent) then | |
280 | Kill_Current_Values (Ent); | |
281 | end if; | |
282 | end; | |
283 | end if; | |
284 | end Kill_Lhs; | |
285 | ||
996ae0b0 RK |
286 | ------------------------- |
287 | -- Set_Assignment_Type -- | |
288 | ------------------------- | |
289 | ||
290 | procedure Set_Assignment_Type | |
291 | (Opnd : Node_Id; | |
292 | Opnd_Type : in out Entity_Id) | |
293 | is | |
5168a9b3 | 294 | Decl : Node_Id; |
3fc40cd7 | 295 | |
996ae0b0 | 296 | begin |
fbf5a39b AC |
297 | Require_Entity (Opnd); |
298 | ||
996ae0b0 | 299 | -- If the assignment operand is an in-out or out parameter, then we |
176dadf6 AC |
300 | -- get the actual subtype (needed for the unconstrained case). If the |
301 | -- operand is the actual in an entry declaration, then within the | |
302 | -- accept statement it is replaced with a local renaming, which may | |
303 | -- also have an actual subtype. | |
996ae0b0 RK |
304 | |
305 | if Is_Entity_Name (Opnd) | |
306 | and then (Ekind (Entity (Opnd)) = E_Out_Parameter | |
ac7d724d ES |
307 | or else Ekind_In (Entity (Opnd), |
308 | E_In_Out_Parameter, | |
309 | E_Generic_In_Out_Parameter) | |
fbf5a39b AC |
310 | or else |
311 | (Ekind (Entity (Opnd)) = E_Variable | |
312 | and then Nkind (Parent (Entity (Opnd))) = | |
3fc40cd7 | 313 | N_Object_Renaming_Declaration |
fbf5a39b | 314 | and then Nkind (Parent (Parent (Entity (Opnd)))) = |
3fc40cd7 | 315 | N_Accept_Statement)) |
996ae0b0 RK |
316 | then |
317 | Opnd_Type := Get_Actual_Subtype (Opnd); | |
318 | ||
319 | -- If assignment operand is a component reference, then we get the | |
320 | -- actual subtype of the component for the unconstrained case. | |
321 | ||
561b5849 | 322 | elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference) |
fbf5a39b | 323 | and then not Is_Unchecked_Union (Opnd_Type) |
996ae0b0 RK |
324 | then |
325 | Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); | |
326 | ||
327 | if Present (Decl) then | |
328 | Insert_Action (N, Decl); | |
329 | Mark_Rewrite_Insertion (Decl); | |
330 | Analyze (Decl); | |
331 | Opnd_Type := Defining_Identifier (Decl); | |
332 | Set_Etype (Opnd, Opnd_Type); | |
333 | Freeze_Itype (Opnd_Type, N); | |
334 | ||
335 | elsif Is_Constrained (Etype (Opnd)) then | |
336 | Opnd_Type := Etype (Opnd); | |
337 | end if; | |
338 | ||
339 | -- For slice, use the constrained subtype created for the slice | |
340 | ||
341 | elsif Nkind (Opnd) = N_Slice then | |
342 | Opnd_Type := Etype (Opnd); | |
343 | end if; | |
344 | end Set_Assignment_Type; | |
345 | ||
3fc40cd7 PMR |
346 | ------------------------------------- |
347 | -- Should_Transform_BIP_Assignment -- | |
348 | ------------------------------------- | |
349 | ||
350 | function Should_Transform_BIP_Assignment | |
351 | (Typ : Entity_Id) return Boolean | |
352 | is | |
353 | Result : Boolean; | |
354 | ||
355 | begin | |
356 | if Expander_Active | |
357 | and then not Is_Limited_View (Typ) | |
358 | and then Is_Build_In_Place_Result_Type (Typ) | |
359 | and then not No_Ctrl_Actions (N) | |
360 | then | |
361 | -- This function is called early, before name resolution is | |
362 | -- complete, so we have to deal with things that might turn into | |
363 | -- function calls later. N_Function_Call and N_Op nodes are the | |
364 | -- obvious case. An N_Identifier or N_Expanded_Name is a | |
365 | -- parameterless function call if it denotes a function. | |
366 | -- Finally, an attribute reference can be a function call. | |
367 | ||
368 | case Nkind (Unqual_Conv (Rhs)) is | |
369 | when N_Function_Call | |
370 | | N_Op | |
371 | => | |
372 | Result := True; | |
373 | ||
374 | when N_Expanded_Name | |
375 | | N_Identifier | |
376 | => | |
377 | case Ekind (Entity (Unqual_Conv (Rhs))) is | |
378 | when E_Function | |
379 | | E_Operator | |
380 | => | |
381 | Result := True; | |
382 | ||
383 | when others => | |
384 | Result := False; | |
385 | end case; | |
386 | ||
387 | when N_Attribute_Reference => | |
388 | Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input; | |
389 | -- T'Input will turn into a call whose result type is T | |
390 | ||
391 | when others => | |
392 | Result := False; | |
393 | end case; | |
394 | else | |
395 | Result := False; | |
396 | end if; | |
397 | ||
398 | return Result; | |
399 | end Should_Transform_BIP_Assignment; | |
400 | ||
401 | ------------------------------ | |
402 | -- Transform_BIP_Assignment -- | |
403 | ------------------------------ | |
404 | ||
405 | procedure Transform_BIP_Assignment (Typ : Entity_Id) is | |
406 | ||
407 | -- Tranform "X : [constant] T := F (...);" into: | |
408 | -- | |
409 | -- Temp : constant T := F (...); | |
410 | -- X := Temp; | |
411 | ||
412 | Loc : constant Source_Ptr := Sloc (N); | |
413 | Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); | |
414 | Obj_Decl : constant Node_Id := | |
415 | Make_Object_Declaration (Loc, | |
416 | Defining_Identifier => Def_Id, | |
417 | Constant_Present => True, | |
418 | Object_Definition => New_Occurrence_Of (Typ, Loc), | |
419 | Expression => Rhs, | |
420 | Has_Init_Expression => True); | |
421 | ||
422 | begin | |
423 | Set_Etype (Def_Id, Typ); | |
424 | Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); | |
425 | ||
426 | -- At this point, Rhs is no longer equal to Expression (N), so: | |
427 | ||
428 | Rhs := Expression (N); | |
429 | ||
430 | Insert_Action (N, Obj_Decl); | |
431 | end Transform_BIP_Assignment; | |
432 | ||
5efc1c00 HK |
433 | --------------------- |
434 | -- Within_Function -- | |
435 | --------------------- | |
436 | ||
437 | function Within_Function return Boolean is | |
438 | Scop_Id : constant Entity_Id := Current_Scope; | |
439 | ||
440 | begin | |
441 | if Ekind (Scop_Id) = E_Function then | |
442 | return True; | |
443 | ||
444 | elsif Ekind (Enclosing_Dynamic_Scope (Scop_Id)) = E_Function then | |
445 | return True; | |
446 | end if; | |
447 | ||
448 | return False; | |
449 | end Within_Function; | |
450 | ||
1af4455a HK |
451 | -- Local variables |
452 | ||
b3b3ada9 HK |
453 | Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
454 | Saved_IGR : constant Node_Id := Ignored_Ghost_Region; | |
455 | -- Save the Ghost-related attributes to restore on exit | |
456 | ||
5168a9b3 PMR |
457 | T1 : Entity_Id; |
458 | T2 : Entity_Id; | |
459 | ||
dcd5fd67 PMR |
460 | Save_Full_Analysis : Boolean := False; |
461 | -- Force initialization to facilitate static analysis | |
5168a9b3 | 462 | |
996ae0b0 RK |
463 | -- Start of processing for Analyze_Assignment |
464 | ||
465 | begin | |
1b6c95c4 RD |
466 | Mark_Coextensions (N, Rhs); |
467 | ||
90e491a7 PMR |
468 | -- Preserve relevant elaboration-related attributes of the context which |
469 | -- are no longer available or very expensive to recompute once analysis, | |
470 | -- resolution, and expansion are over. | |
471 | ||
472 | Mark_Elaboration_Attributes | |
473 | (N_Id => N, | |
474 | Checks => True, | |
475 | Modes => True); | |
476 | ||
1af4455a HK |
477 | -- An assignment statement is Ghost when the left hand side denotes a |
478 | -- Ghost entity. Set the mode now to ensure that any nodes generated | |
479 | -- during analysis and expansion are properly marked as Ghost. | |
8636f52f | 480 | |
b3b3ada9 HK |
481 | Mark_And_Set_Ghost_Assignment (N); |
482 | ||
b03d3f73 | 483 | if Has_Target_Names (N) then |
f8a21934 | 484 | Current_Assignment := N; |
b03d3f73 | 485 | Expander_Mode_Save_And_Set (False); |
f8a21934 AC |
486 | Save_Full_Analysis := Full_Analysis; |
487 | Full_Analysis := False; | |
488 | else | |
489 | Current_Assignment := Empty; | |
b03d3f73 AC |
490 | end if; |
491 | ||
b3b3ada9 | 492 | Analyze (Lhs); |
c5cec2fe | 493 | Analyze (Rhs); |
c8ef728f | 494 | |
273adcdf | 495 | -- Ensure that we never do an assignment on a variable marked as |
b6e6a4e3 | 496 | -- Is_Safe_To_Reevaluate. |
273adcdf | 497 | |
b6e6a4e3 AC |
498 | pragma Assert |
499 | (not Is_Entity_Name (Lhs) | |
500 | or else Ekind (Entity (Lhs)) /= E_Variable | |
501 | or else not Is_Safe_To_Reevaluate (Entity (Lhs))); | |
273adcdf | 502 | |
c8ef728f ES |
503 | -- Start type analysis for assignment |
504 | ||
996ae0b0 RK |
505 | T1 := Etype (Lhs); |
506 | ||
507 | -- In the most general case, both Lhs and Rhs can be overloaded, and we | |
508 | -- must compute the intersection of the possible types on each side. | |
509 | ||
510 | if Is_Overloaded (Lhs) then | |
511 | declare | |
512 | I : Interp_Index; | |
513 | It : Interp; | |
514 | ||
515 | begin | |
516 | T1 := Any_Type; | |
517 | Get_First_Interp (Lhs, I, It); | |
518 | ||
519 | while Present (It.Typ) loop | |
48bb06a7 | 520 | |
a2c314c7 | 521 | -- An indexed component with generalized indexing is always |
48bb06a7 AC |
522 | -- overloaded with the corresponding dereference. Discard the |
523 | -- interpretation that yields a reference type, which is not | |
524 | -- assignable. | |
a2c314c7 AC |
525 | |
526 | if Nkind (Lhs) = N_Indexed_Component | |
527 | and then Present (Generalized_Indexing (Lhs)) | |
528 | and then Has_Implicit_Dereference (It.Typ) | |
529 | then | |
f4ef7b06 AC |
530 | null; |
531 | ||
532 | -- This may be a call to a parameterless function through an | |
533 | -- implicit dereference, so discard interpretation as well. | |
534 | ||
535 | elsif Is_Entity_Name (Lhs) | |
536 | and then Has_Implicit_Dereference (It.Typ) | |
537 | then | |
a2c314c7 AC |
538 | null; |
539 | ||
540 | elsif Has_Compatible_Type (Rhs, It.Typ) then | |
5168a9b3 PMR |
541 | if T1 = Any_Type then |
542 | T1 := It.Typ; | |
543 | else | |
996ae0b0 RK |
544 | -- An explicit dereference is overloaded if the prefix |
545 | -- is. Try to remove the ambiguity on the prefix, the | |
546 | -- error will be posted there if the ambiguity is real. | |
547 | ||
548 | if Nkind (Lhs) = N_Explicit_Dereference then | |
549 | declare | |
550 | PI : Interp_Index; | |
551 | PI1 : Interp_Index := 0; | |
552 | PIt : Interp; | |
553 | Found : Boolean; | |
554 | ||
555 | begin | |
556 | Found := False; | |
557 | Get_First_Interp (Prefix (Lhs), PI, PIt); | |
558 | ||
559 | while Present (PIt.Typ) loop | |
fbf5a39b AC |
560 | if Is_Access_Type (PIt.Typ) |
561 | and then Has_Compatible_Type | |
562 | (Rhs, Designated_Type (PIt.Typ)) | |
996ae0b0 RK |
563 | then |
564 | if Found then | |
565 | PIt := | |
566 | Disambiguate (Prefix (Lhs), | |
567 | PI1, PI, Any_Type); | |
568 | ||
569 | if PIt = No_Interp then | |
fbf5a39b | 570 | Error_Msg_N |
d65a80fd HK |
571 | ("ambiguous left-hand side in " |
572 | & "assignment", Lhs); | |
fbf5a39b | 573 | exit; |
996ae0b0 RK |
574 | else |
575 | Resolve (Prefix (Lhs), PIt.Typ); | |
576 | end if; | |
577 | ||
578 | exit; | |
579 | else | |
580 | Found := True; | |
581 | PI1 := PI; | |
582 | end if; | |
583 | end if; | |
584 | ||
585 | Get_Next_Interp (PI, PIt); | |
586 | end loop; | |
587 | end; | |
588 | ||
589 | else | |
590 | Error_Msg_N | |
591 | ("ambiguous left-hand side in assignment", Lhs); | |
592 | exit; | |
593 | end if; | |
996ae0b0 RK |
594 | end if; |
595 | end if; | |
596 | ||
597 | Get_Next_Interp (I, It); | |
598 | end loop; | |
599 | end; | |
600 | ||
601 | if T1 = Any_Type then | |
602 | Error_Msg_N | |
603 | ("no valid types for left-hand side for assignment", Lhs); | |
c8ef728f | 604 | Kill_Lhs; |
d65a80fd | 605 | goto Leave; |
996ae0b0 RK |
606 | end if; |
607 | end if; | |
608 | ||
3fc40cd7 PMR |
609 | -- Deal with build-in-place calls for nonlimited types. We don't do this |
610 | -- later, because resolving the rhs tranforms it incorrectly for build- | |
611 | -- in-place. | |
5168a9b3 PMR |
612 | |
613 | if Should_Transform_BIP_Assignment (Typ => T1) then | |
967947ed | 614 | |
d00301ec BD |
615 | -- In certain cases involving user-defined concatenation operators, |
616 | -- we need to resolve the right-hand side before transforming the | |
617 | -- assignment. | |
618 | ||
619 | case Nkind (Unqual_Conv (Rhs)) is | |
620 | when N_Function_Call => | |
621 | declare | |
622 | Actual : Node_Id := | |
623 | First (Parameter_Associations (Unqual_Conv (Rhs))); | |
624 | Actual_Exp : Node_Id; | |
625 | ||
626 | begin | |
627 | while Present (Actual) loop | |
628 | if Nkind (Actual) = N_Parameter_Association then | |
629 | Actual_Exp := Explicit_Actual_Parameter (Actual); | |
630 | else | |
631 | Actual_Exp := Actual; | |
632 | end if; | |
633 | ||
634 | if Nkind (Actual_Exp) = N_Op_Concat then | |
635 | Resolve (Rhs, T1); | |
636 | exit; | |
637 | end if; | |
638 | ||
639 | Next (Actual); | |
640 | end loop; | |
641 | end; | |
642 | ||
967947ed | 643 | when N_Attribute_Reference |
d00301ec BD |
644 | | N_Expanded_Name |
645 | | N_Identifier | |
967947ed | 646 | | N_Op |
d00301ec BD |
647 | => |
648 | null; | |
649 | ||
650 | when others => | |
651 | raise Program_Error; | |
652 | end case; | |
653 | ||
5168a9b3 PMR |
654 | Transform_BIP_Assignment (Typ => T1); |
655 | end if; | |
3fc40cd7 | 656 | |
5168a9b3 PMR |
657 | pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); |
658 | ||
176dadf6 AC |
659 | -- The resulting assignment type is T1, so now we will resolve the left |
660 | -- hand side of the assignment using this determined type. | |
27c489df | 661 | |
996ae0b0 RK |
662 | Resolve (Lhs, T1); |
663 | ||
a2667f14 AC |
664 | -- Cases where Lhs is not a variable. In an instance or an inlined body |
665 | -- no need for further check because assignment was legal in template. | |
666 | ||
667 | if In_Inlined_Body then | |
668 | null; | |
669 | ||
670 | elsif not Is_Variable (Lhs) then | |
2a806772 | 671 | |
176dadf6 AC |
672 | -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a |
673 | -- protected object. | |
2a806772 RD |
674 | |
675 | declare | |
676 | Ent : Entity_Id; | |
677 | S : Entity_Id; | |
678 | ||
679 | begin | |
0791fbe9 | 680 | if Ada_Version >= Ada_2005 then |
2a806772 RD |
681 | |
682 | -- Handle chains of renamings | |
683 | ||
684 | Ent := Lhs; | |
685 | while Nkind (Ent) in N_Has_Entity | |
686 | and then Present (Entity (Ent)) | |
687 | and then Present (Renamed_Object (Entity (Ent))) | |
688 | loop | |
689 | Ent := Renamed_Object (Entity (Ent)); | |
690 | end loop; | |
691 | ||
692 | if (Nkind (Ent) = N_Attribute_Reference | |
ac7d724d | 693 | and then Attribute_Name (Ent) = Name_Priority) |
2a806772 RD |
694 | |
695 | -- Renamings of the attribute Priority applied to protected | |
696 | -- objects have been previously expanded into calls to the | |
697 | -- Get_Ceiling run-time subprogram. | |
698 | ||
f73dc37f | 699 | or else Is_Expanded_Priority_Attribute (Ent) |
2a806772 RD |
700 | then |
701 | -- The enclosing subprogram cannot be a protected function | |
702 | ||
703 | S := Current_Scope; | |
704 | while not (Is_Subprogram (S) | |
ac7d724d | 705 | and then Convention (S) = Convention_Protected) |
2a806772 RD |
706 | and then S /= Standard_Standard |
707 | loop | |
708 | S := Scope (S); | |
709 | end loop; | |
710 | ||
711 | if Ekind (S) = E_Function | |
712 | and then Convention (S) = Convention_Protected | |
713 | then | |
714 | Error_Msg_N | |
715 | ("protected function cannot modify protected object", | |
716 | Lhs); | |
717 | end if; | |
718 | ||
719 | -- Changes of the ceiling priority of the protected object | |
720 | -- are only effective if the Ceiling_Locking policy is in | |
721 | -- effect (AARM D.5.2 (5/2)). | |
722 | ||
723 | if Locking_Policy /= 'C' then | |
d65a80fd HK |
724 | Error_Msg_N |
725 | ("assignment to the attribute PRIORITY has no effect??", | |
726 | Lhs); | |
727 | Error_Msg_N | |
728 | ("\since no Locking_Policy has been specified??", Lhs); | |
2a806772 RD |
729 | end if; |
730 | ||
d65a80fd | 731 | goto Leave; |
2a806772 RD |
732 | end if; |
733 | end if; | |
734 | end; | |
735 | ||
996ae0b0 | 736 | Diagnose_Non_Variable_Lhs (Lhs); |
d65a80fd | 737 | goto Leave; |
996ae0b0 | 738 | |
27c489df RD |
739 | -- Error of assigning to limited type. We do however allow this in |
740 | -- certain cases where the front end generates the assignments. | |
741 | ||
996ae0b0 RK |
742 | elsif Is_Limited_Type (T1) |
743 | and then not Assignment_OK (Lhs) | |
744 | and then not Assignment_OK (Original_Node (Lhs)) | |
745 | then | |
236fecbf JM |
746 | -- CPP constructors can only be called in declarations |
747 | ||
748 | if Is_CPP_Constructor_Call (Rhs) then | |
749 | Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs); | |
750 | else | |
751 | Error_Msg_N | |
752 | ("left hand of assignment must not be limited type", Lhs); | |
753 | Explain_Limited_Type (T1, Lhs); | |
754 | end if; | |
241ebe89 | 755 | |
d65a80fd | 756 | goto Leave; |
45fc7ddb | 757 | |
72d5c70b AC |
758 | -- A class-wide type may be a limited view. This illegal case is not |
759 | -- caught by previous checks. | |
760 | ||
d65a80fd | 761 | elsif Ekind (T1) = E_Class_Wide_Type and then From_Limited_With (T1) then |
72d5c70b | 762 | Error_Msg_NE ("invalid use of limited view of&", Lhs, T1); |
d65a80fd | 763 | goto Leave; |
72d5c70b | 764 | |
b0256cb6 AC |
765 | -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be |
766 | -- abstract. This is only checked when the assignment Comes_From_Source, | |
767 | -- because in some cases the expander generates such assignments (such | |
768 | -- in the _assign operation for an abstract type). | |
45fc7ddb | 769 | |
b0256cb6 | 770 | elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then |
45fc7ddb | 771 | Error_Msg_N |
b0256cb6 | 772 | ("target of assignment operation must not be abstract", Lhs); |
996ae0b0 RK |
773 | end if; |
774 | ||
5efc1c00 HK |
775 | -- Variables which are Part_Of constituents of single protected types |
776 | -- behave in similar fashion to protected components. Such variables | |
777 | -- cannot be modified by protected functions. | |
778 | ||
779 | if Is_Protected_Part_Of_Constituent (Lhs) and then Within_Function then | |
780 | Error_Msg_N | |
781 | ("protected function cannot modify protected object", Lhs); | |
782 | end if; | |
783 | ||
176dadf6 AC |
784 | -- Resolution may have updated the subtype, in case the left-hand side |
785 | -- is a private protected component. Use the correct subtype to avoid | |
786 | -- scoping issues in the back-end. | |
996ae0b0 RK |
787 | |
788 | T1 := Etype (Lhs); | |
d8db0bca JM |
789 | |
790 | -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete | |
791 | -- type. For example: | |
792 | ||
793 | -- limited with P; | |
794 | -- package Pkg is | |
795 | -- type Acc is access P.T; | |
796 | -- end Pkg; | |
797 | ||
798 | -- with Pkg; use Acc; | |
799 | -- procedure Example is | |
800 | -- A, B : Acc; | |
801 | -- begin | |
802 | -- A.all := B.all; -- ERROR | |
803 | -- end Example; | |
804 | ||
805 | if Nkind (Lhs) = N_Explicit_Dereference | |
806 | and then Ekind (T1) = E_Incomplete_Type | |
807 | then | |
808 | Error_Msg_N ("invalid use of incomplete type", Lhs); | |
c8ef728f | 809 | Kill_Lhs; |
d65a80fd | 810 | goto Leave; |
d8db0bca JM |
811 | end if; |
812 | ||
27c489df | 813 | -- Now we can complete the resolution of the right hand side |
996ae0b0 | 814 | |
27c489df | 815 | Set_Assignment_Type (Lhs, T1); |
ae33543c | 816 | |
ec7f007c AC |
817 | -- If the target of the assignment is an entity of a mutable type and |
818 | -- the expression is a conditional expression, its alternatives can be | |
819 | -- of different subtypes of the nominal type of the LHS, so they must be | |
820 | -- resolved with the base type, given that their subtype may differ from | |
821 | -- that of the target mutable object. | |
c48e0f27 AC |
822 | |
823 | if Is_Entity_Name (Lhs) | |
ec7f007c AC |
824 | and then Ekind_In (Entity (Lhs), E_In_Out_Parameter, |
825 | E_Out_Parameter, | |
826 | E_Variable) | |
c48e0f27 AC |
827 | and then Is_Composite_Type (T1) |
828 | and then not Is_Constrained (Etype (Entity (Lhs))) | |
829 | and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression) | |
830 | then | |
831 | Resolve (Rhs, Base_Type (T1)); | |
832 | ||
833 | else | |
834 | Resolve (Rhs, T1); | |
835 | end if; | |
27c489df RD |
836 | |
837 | -- This is the point at which we check for an unset reference | |
838 | ||
30c20106 | 839 | Check_Unset_Reference (Rhs); |
45fc7ddb | 840 | Check_Unprotected_Access (Lhs, Rhs); |
996ae0b0 | 841 | |
fbf5a39b | 842 | -- Remaining steps are skipped if Rhs was syntactically in error |
996ae0b0 RK |
843 | |
844 | if Rhs = Error then | |
c8ef728f | 845 | Kill_Lhs; |
d65a80fd | 846 | goto Leave; |
996ae0b0 RK |
847 | end if; |
848 | ||
849 | T2 := Etype (Rhs); | |
996ae0b0 | 850 | |
ec53a6da | 851 | if not Covers (T1, T2) then |
996ae0b0 | 852 | Wrong_Type (Rhs, Etype (Lhs)); |
c8ef728f | 853 | Kill_Lhs; |
d65a80fd | 854 | goto Leave; |
996ae0b0 RK |
855 | end if; |
856 | ||
d8db0bca JM |
857 | -- Ada 2005 (AI-326): In case of explicit dereference of incomplete |
858 | -- types, use the non-limited view if available | |
859 | ||
860 | if Nkind (Rhs) = N_Explicit_Dereference | |
d8db0bca | 861 | and then Is_Tagged_Type (T2) |
47346923 | 862 | and then Has_Non_Limited_View (T2) |
d8db0bca JM |
863 | then |
864 | T2 := Non_Limited_View (T2); | |
865 | end if; | |
866 | ||
996ae0b0 RK |
867 | Set_Assignment_Type (Rhs, T2); |
868 | ||
fbf5a39b AC |
869 | if Total_Errors_Detected /= 0 then |
870 | if No (T1) then | |
871 | T1 := Any_Type; | |
872 | end if; | |
873 | ||
874 | if No (T2) then | |
875 | T2 := Any_Type; | |
876 | end if; | |
877 | end if; | |
878 | ||
996ae0b0 | 879 | if T1 = Any_Type or else T2 = Any_Type then |
c8ef728f | 880 | Kill_Lhs; |
d65a80fd | 881 | goto Leave; |
996ae0b0 RK |
882 | end if; |
883 | ||
27c489df RD |
884 | -- If the rhs is class-wide or dynamically tagged, then require the lhs |
885 | -- to be class-wide. The case where the rhs is a dynamically tagged call | |
886 | -- to a dispatching operation with a controlling access result is | |
887 | -- excluded from this check, since the target has an access type (and | |
888 | -- no tag propagation occurs in that case). | |
889 | ||
890 | if (Is_Class_Wide_Type (T2) | |
891 | or else (Is_Dynamically_Tagged (Rhs) | |
892 | and then not Is_Access_Type (T1))) | |
996ae0b0 RK |
893 | and then not Is_Class_Wide_Type (T1) |
894 | then | |
895 | Error_Msg_N ("dynamically tagged expression not allowed!", Rhs); | |
896 | ||
897 | elsif Is_Class_Wide_Type (T1) | |
898 | and then not Is_Class_Wide_Type (T2) | |
899 | and then not Is_Tag_Indeterminate (Rhs) | |
900 | and then not Is_Dynamically_Tagged (Rhs) | |
901 | then | |
ed2233dc | 902 | Error_Msg_N ("dynamically tagged expression required!", Rhs); |
996ae0b0 RK |
903 | end if; |
904 | ||
c8ef728f ES |
905 | -- Propagate the tag from a class-wide target to the rhs when the rhs |
906 | -- is a tag-indeterminate call. | |
996ae0b0 | 907 | |
b6a1a16f ES |
908 | if Is_Tag_Indeterminate (Rhs) then |
909 | if Is_Class_Wide_Type (T1) then | |
910 | Propagate_Tag (Lhs, Rhs); | |
911 | ||
912 | elsif Nkind (Rhs) = N_Function_Call | |
ac7d724d ES |
913 | and then Is_Entity_Name (Name (Rhs)) |
914 | and then Is_Abstract_Subprogram (Entity (Name (Rhs))) | |
b6a1a16f | 915 | then |
ed2233dc | 916 | Error_Msg_N |
b6a1a16f ES |
917 | ("call to abstract function must be dispatching", Name (Rhs)); |
918 | ||
919 | elsif Nkind (Rhs) = N_Qualified_Expression | |
920 | and then Nkind (Expression (Rhs)) = N_Function_Call | |
921 | and then Is_Entity_Name (Name (Expression (Rhs))) | |
922 | and then | |
923 | Is_Abstract_Subprogram (Entity (Name (Expression (Rhs)))) | |
924 | then | |
ed2233dc | 925 | Error_Msg_N |
b6a1a16f ES |
926 | ("call to abstract function must be dispatching", |
927 | Name (Expression (Rhs))); | |
928 | end if; | |
996ae0b0 RK |
929 | end if; |
930 | ||
b1c11e0e JM |
931 | -- Ada 2005 (AI-385): When the lhs type is an anonymous access type, |
932 | -- apply an implicit conversion of the rhs to that type to force | |
434d3cf1 AC |
933 | -- appropriate static and run-time accessibility checks. This applies |
934 | -- as well to anonymous access-to-subprogram types that are component | |
935 | -- subtypes or formal parameters. | |
bc49df98 | 936 | |
ac7d724d | 937 | if Ada_Version >= Ada_2005 and then Is_Access_Type (T1) then |
434d3cf1 AC |
938 | if Is_Local_Anonymous_Access (T1) |
939 | or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type | |
d15f9422 AC |
940 | |
941 | -- Handle assignment to an Ada 2012 stand-alone object | |
942 | -- of an anonymous access type. | |
943 | ||
944 | or else (Ekind (T1) = E_Anonymous_Access_Type | |
996c8821 RD |
945 | and then Nkind (Associated_Node_For_Itype (T1)) = |
946 | N_Object_Declaration) | |
d15f9422 | 947 | |
434d3cf1 AC |
948 | then |
949 | Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); | |
950 | Analyze_And_Resolve (Rhs, T1); | |
951 | end if; | |
bc49df98 GD |
952 | end if; |
953 | ||
3b8b7270 | 954 | -- Ada 2005 (AI-231): Assignment to not null variable |
2820d220 | 955 | |
0791fbe9 | 956 | if Ada_Version >= Ada_2005 |
ec53a6da | 957 | and then Can_Never_Be_Null (T1) |
2820d220 | 958 | and then not Assignment_OK (Lhs) |
2820d220 | 959 | then |
3b8b7270 RD |
960 | -- Case where we know the right hand side is null |
961 | ||
1b6c95c4 | 962 | if Known_Null (Rhs) then |
ec53a6da | 963 | Apply_Compile_Time_Constraint_Error |
324ac540 AC |
964 | (N => Rhs, |
965 | Msg => | |
966 | "(Ada 2005) null not allowed in null-excluding objects??", | |
ec53a6da | 967 | Reason => CE_Null_Not_Allowed); |
3b8b7270 RD |
968 | |
969 | -- We still mark this as a possible modification, that's necessary | |
970 | -- to reset Is_True_Constant, and desirable for xref purposes. | |
971 | ||
45fc7ddb | 972 | Note_Possible_Modification (Lhs, Sure => True); |
d65a80fd | 973 | goto Leave; |
ec53a6da | 974 | |
3b8b7270 RD |
975 | -- If we know the right hand side is non-null, then we convert to the |
976 | -- target type, since we don't need a run time check in that case. | |
977 | ||
ec53a6da | 978 | elsif not Can_Never_Be_Null (T2) then |
3b8b7270 | 979 | Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs))); |
ec53a6da JM |
980 | Analyze_And_Resolve (Rhs, T1); |
981 | end if; | |
2820d220 AC |
982 | end if; |
983 | ||
996ae0b0 RK |
984 | if Is_Scalar_Type (T1) then |
985 | Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); | |
986 | ||
c8ef728f | 987 | -- For array types, verify that lengths match. If the right hand side |
176dadf6 | 988 | -- is a function call that has been inlined, the assignment has been |
c8ef728f ES |
989 | -- rewritten as a block, and the constraint check will be applied to the |
990 | -- assignment within the block. | |
991 | ||
fbf5a39b | 992 | elsif Is_Array_Type (T1) |
ac7d724d ES |
993 | and then (Nkind (Rhs) /= N_Type_Conversion |
994 | or else Is_Constrained (Etype (Rhs))) | |
995 | and then (Nkind (Rhs) /= N_Function_Call | |
996 | or else Nkind (N) /= N_Block_Statement) | |
fbf5a39b | 997 | then |
996ae0b0 | 998 | -- Assignment verifies that the length of the Lsh and Rhs are equal, |
3b42c566 | 999 | -- but of course the indexes do not have to match. If the right-hand |
fbf5a39b AC |
1000 | -- side is a type conversion to an unconstrained type, a length check |
1001 | -- is performed on the expression itself during expansion. In rare | |
1002 | -- cases, the redundant length check is computed on an index type | |
176dadf6 AC |
1003 | -- with a different representation, triggering incorrect code in the |
1004 | -- back end. | |
996ae0b0 RK |
1005 | |
1006 | Apply_Length_Check (Rhs, Etype (Lhs)); | |
1007 | ||
1008 | else | |
30c20106 AC |
1009 | -- Discriminant checks are applied in the course of expansion |
1010 | ||
996ae0b0 RK |
1011 | null; |
1012 | end if; | |
1013 | ||
30c20106 AC |
1014 | -- Note: modifications of the Lhs may only be recorded after |
1015 | -- checks have been applied. | |
1016 | ||
45fc7ddb | 1017 | Note_Possible_Modification (Lhs, Sure => True); |
30c20106 | 1018 | |
996ae0b0 RK |
1019 | -- ??? a real accessibility check is needed when ??? |
1020 | ||
2a806772 | 1021 | -- Post warning for redundant assignment or variable to itself |
996ae0b0 RK |
1022 | |
1023 | if Warn_On_Redundant_Constructs | |
1024 | ||
1025 | -- We only warn for source constructs | |
1026 | ||
1027 | and then Comes_From_Source (N) | |
1028 | ||
1b6c95c4 | 1029 | -- Where the object is the same on both sides |
996ae0b0 | 1030 | |
1b6c95c4 | 1031 | and then Same_Object (Lhs, Original_Node (Rhs)) |
996ae0b0 | 1032 | |
176dadf6 AC |
1033 | -- But exclude the case where the right side was an operation that |
1034 | -- got rewritten (e.g. JUNK + K, where K was known to be zero). We | |
1035 | -- don't want to warn in such a case, since it is reasonable to write | |
1036 | -- such expressions especially when K is defined symbolically in some | |
1037 | -- other package. | |
996ae0b0 RK |
1038 | |
1039 | and then Nkind (Original_Node (Rhs)) not in N_Op | |
1040 | then | |
1b6c95c4 | 1041 | if Nkind (Lhs) in N_Has_Entity then |
305caf42 | 1042 | Error_Msg_NE -- CODEFIX |
324ac540 | 1043 | ("?r?useless assignment of & to itself!", N, Entity (Lhs)); |
1b6c95c4 | 1044 | else |
305caf42 | 1045 | Error_Msg_N -- CODEFIX |
324ac540 | 1046 | ("?r?useless assignment of object to itself!", N); |
1b6c95c4 | 1047 | end if; |
996ae0b0 | 1048 | end if; |
fbf5a39b | 1049 | |
fbf5a39b AC |
1050 | -- Check for non-allowed composite assignment |
1051 | ||
1052 | if not Support_Composite_Assign_On_Target | |
1053 | and then (Is_Array_Type (T1) or else Is_Record_Type (T1)) | |
1054 | and then (not Has_Size_Clause (T1) or else Esize (T1) > 64) | |
1055 | then | |
1056 | Error_Msg_CRT ("composite assignment", N); | |
1057 | end if; | |
1058 | ||
967947ed PMR |
1059 | -- Check elaboration warning for left side if not in elab code |
1060 | ||
1061 | if Legacy_Elaboration_Checks | |
1062 | and not In_Subprogram_Or_Concurrent_Unit | |
1063 | then | |
1064 | Check_Elab_Assign (Lhs); | |
1065 | end if; | |
1066 | ||
90e491a7 | 1067 | -- Save the scenario for later examination by the ABE Processing phase |
2a806772 | 1068 | |
90e491a7 | 1069 | Record_Elaboration_Scenario (N); |
2a806772 | 1070 | |
561b5849 RD |
1071 | -- Set Referenced_As_LHS if appropriate. We only set this flag if the |
1072 | -- assignment is a source assignment in the extended main source unit. | |
1073 | -- We are not interested in any reference information outside this | |
1074 | -- context, or in compiler generated assignment statements. | |
1075 | ||
1076 | if Comes_From_Source (N) | |
1077 | and then In_Extended_Main_Source_Unit (Lhs) | |
1078 | then | |
1079 | Set_Referenced_Modified (Lhs, Out_Param => False); | |
1080 | end if; | |
1081 | ||
61b14896 PMR |
1082 | -- RM 7.3.2 (12/3): An assignment to a view conversion (from a type to |
1083 | -- one of its ancestors) requires an invariant check. Apply check only | |
1084 | -- if expression comes from source, otherwise it will be applied when | |
1085 | -- value is assigned to source entity. This is not done in GNATprove | |
1086 | -- mode, as GNATprove handles invariant checks itself. | |
4ffafd86 AC |
1087 | |
1088 | if Nkind (Lhs) = N_Type_Conversion | |
1089 | and then Has_Invariants (Etype (Expression (Lhs))) | |
1090 | and then Comes_From_Source (Expression (Lhs)) | |
61b14896 | 1091 | and then not GNATprove_Mode |
4ffafd86 AC |
1092 | then |
1093 | Insert_After (N, Make_Invariant_Call (Expression (Lhs))); | |
1094 | end if; | |
1095 | ||
176dadf6 AC |
1096 | -- Final step. If left side is an entity, then we may be able to reset |
1097 | -- the current tracked values to new safe values. We only have something | |
1098 | -- to do if the left side is an entity name, and expansion has not | |
1099 | -- modified the node into something other than an assignment, and of | |
1100 | -- course we only capture values if it is safe to do so. | |
fbf5a39b | 1101 | |
c8ef728f ES |
1102 | if Is_Entity_Name (Lhs) |
1103 | and then Nkind (N) = N_Assignment_Statement | |
1104 | then | |
1105 | declare | |
1106 | Ent : constant Entity_Id := Entity (Lhs); | |
fbf5a39b | 1107 | |
c8ef728f ES |
1108 | begin |
1109 | if Safe_To_Capture_Value (N, Ent) then | |
fbf5a39b | 1110 | |
2a806772 | 1111 | -- If simple variable on left side, warn if this assignment |
c2db4b32 AC |
1112 | -- blots out another one (rendering it useless). We only do |
1113 | -- this for source assignments, otherwise we can generate bogus | |
1114 | -- warnings when an assignment is rewritten as another | |
1115 | -- assignment, and gets tied up with itself. | |
67ce0d7e | 1116 | |
0da343bc AC |
1117 | -- There may have been a previous reference to a component of |
1118 | -- the variable, which in general removes the Last_Assignment | |
1119 | -- field of the variable to indicate a relevant use of the | |
1120 | -- previous assignment. However, if the assignment is to a | |
1121 | -- subcomponent the reference may not have registered, because | |
1122 | -- it is not possible to determine whether the context is an | |
1123 | -- assignment. In those cases we generate a Deferred_Reference, | |
1124 | -- to be used at the end of compilation to generate the right | |
1125 | -- kind of reference, and we suppress a potential warning for | |
1126 | -- a useless assignment, which might be premature. This may | |
1127 | -- lose a warning in rare cases, but seems preferable to a | |
1128 | -- misleading warning. | |
1129 | ||
2a806772 | 1130 | if Warn_On_Modified_Unread |
67ce0d7e | 1131 | and then Is_Assignable (Ent) |
2a806772 RD |
1132 | and then Comes_From_Source (N) |
1133 | and then In_Extended_Main_Source_Unit (Ent) | |
0da343bc | 1134 | and then not Has_Deferred_Reference (Ent) |
2a806772 | 1135 | then |
561b5849 | 1136 | Warn_On_Useless_Assignment (Ent, N); |
2a806772 RD |
1137 | end if; |
1138 | ||
c8ef728f ES |
1139 | -- If we are assigning an access type and the left side is an |
1140 | -- entity, then make sure that the Is_Known_[Non_]Null flags | |
1141 | -- properly reflect the state of the entity after assignment. | |
fbf5a39b | 1142 | |
c8ef728f ES |
1143 | if Is_Access_Type (T1) then |
1144 | if Known_Non_Null (Rhs) then | |
1145 | Set_Is_Known_Non_Null (Ent, True); | |
fbf5a39b | 1146 | |
c8ef728f ES |
1147 | elsif Known_Null (Rhs) |
1148 | and then not Can_Never_Be_Null (Ent) | |
1149 | then | |
1150 | Set_Is_Known_Null (Ent, True); | |
fbf5a39b | 1151 | |
c8ef728f ES |
1152 | else |
1153 | Set_Is_Known_Null (Ent, False); | |
fbf5a39b | 1154 | |
c8ef728f ES |
1155 | if not Can_Never_Be_Null (Ent) then |
1156 | Set_Is_Known_Non_Null (Ent, False); | |
1157 | end if; | |
1158 | end if; | |
fbf5a39b | 1159 | |
c8ef728f ES |
1160 | -- For discrete types, we may be able to set the current value |
1161 | -- if the value is known at compile time. | |
1162 | ||
1163 | elsif Is_Discrete_Type (T1) | |
1164 | and then Compile_Time_Known_Value (Rhs) | |
1165 | then | |
1166 | Set_Current_Value (Ent, Rhs); | |
1167 | else | |
1168 | Set_Current_Value (Ent, Empty); | |
1169 | end if; | |
1170 | ||
1171 | -- If not safe to capture values, kill them | |
1172 | ||
1173 | else | |
1174 | Kill_Lhs; | |
1175 | end if; | |
1176 | end; | |
fbf5a39b | 1177 | end if; |
c2db4b32 AC |
1178 | |
1179 | -- If assigning to an object in whole or in part, note location of | |
1180 | -- assignment in case no one references value. We only do this for | |
1181 | -- source assignments, otherwise we can generate bogus warnings when an | |
1182 | -- assignment is rewritten as another assignment, and gets tied up with | |
1183 | -- itself. | |
1184 | ||
1185 | declare | |
1186 | Ent : constant Entity_Id := Get_Enclosing_Object (Lhs); | |
c2db4b32 AC |
1187 | begin |
1188 | if Present (Ent) | |
1189 | and then Safe_To_Capture_Value (N, Ent) | |
1190 | and then Nkind (N) = N_Assignment_Statement | |
1191 | and then Warn_On_Modified_Unread | |
1192 | and then Is_Assignable (Ent) | |
1193 | and then Comes_From_Source (N) | |
1194 | and then In_Extended_Main_Source_Unit (Ent) | |
1195 | then | |
1196 | Set_Last_Assignment (Ent, Lhs); | |
1197 | end if; | |
1198 | end; | |
54c04d6c | 1199 | |
dec6faf1 | 1200 | Analyze_Dimension (N); |
d65a80fd HK |
1201 | |
1202 | <<Leave>> | |
9057bd6a | 1203 | Restore_Ghost_Region (Saved_GM, Saved_IGR); |
b41c731f AC |
1204 | |
1205 | -- If the right-hand side contains target names, expansion has been | |
1206 | -- disabled to prevent expansion that might move target names out of | |
1207 | -- the context of the assignment statement. Restore the expander mode | |
1208 | -- now so that assignment statement can be properly expanded. | |
1209 | ||
3a248f7c BD |
1210 | if Nkind (N) = N_Assignment_Statement then |
1211 | if Has_Target_Names (N) then | |
1212 | Expander_Mode_Restore; | |
1213 | Full_Analysis := Save_Full_Analysis; | |
1214 | end if; | |
5168a9b3 | 1215 | |
3a248f7c BD |
1216 | pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); |
1217 | end if; | |
996ae0b0 RK |
1218 | end Analyze_Assignment; |
1219 | ||
1220 | ----------------------------- | |
1221 | -- Analyze_Block_Statement -- | |
1222 | ----------------------------- | |
1223 | ||
1224 | procedure Analyze_Block_Statement (N : Node_Id) is | |
0613fb33 AC |
1225 | procedure Install_Return_Entities (Scop : Entity_Id); |
1226 | -- Install all entities of return statement scope Scop in the visibility | |
1227 | -- chain except for the return object since its entity is reused in a | |
1228 | -- renaming. | |
1229 | ||
1230 | ----------------------------- | |
1231 | -- Install_Return_Entities -- | |
1232 | ----------------------------- | |
1233 | ||
1234 | procedure Install_Return_Entities (Scop : Entity_Id) is | |
1235 | Id : Entity_Id; | |
1236 | ||
1237 | begin | |
1238 | Id := First_Entity (Scop); | |
1239 | while Present (Id) loop | |
1240 | ||
1241 | -- Do not install the return object | |
1242 | ||
1243 | if not Ekind_In (Id, E_Constant, E_Variable) | |
1244 | or else not Is_Return_Object (Id) | |
1245 | then | |
1246 | Install_Entity (Id); | |
1247 | end if; | |
1248 | ||
1249 | Next_Entity (Id); | |
1250 | end loop; | |
1251 | end Install_Return_Entities; | |
1252 | ||
1253 | -- Local constants and variables | |
1254 | ||
996ae0b0 RK |
1255 | Decls : constant List_Id := Declarations (N); |
1256 | Id : constant Node_Id := Identifier (N); | |
6f21ed26 | 1257 | HSS : constant Node_Id := Handled_Statement_Sequence (N); |
996ae0b0 | 1258 | |
0613fb33 AC |
1259 | Is_BIP_Return_Statement : Boolean; |
1260 | ||
1261 | -- Start of processing for Analyze_Block_Statement | |
1262 | ||
996ae0b0 | 1263 | begin |
176dadf6 AC |
1264 | -- If no handled statement sequence is present, things are really messed |
1265 | -- up, and we just return immediately (defence against previous errors). | |
996ae0b0 | 1266 | |
6f21ed26 | 1267 | if No (HSS) then |
ee2ba856 | 1268 | Check_Error_Detected; |
6f21ed26 RD |
1269 | return; |
1270 | end if; | |
996ae0b0 | 1271 | |
0613fb33 AC |
1272 | -- Detect whether the block is actually a rewritten return statement of |
1273 | -- a build-in-place function. | |
1274 | ||
1275 | Is_BIP_Return_Statement := | |
1276 | Present (Id) | |
1277 | and then Present (Entity (Id)) | |
1278 | and then Ekind (Entity (Id)) = E_Return_Statement | |
1279 | and then Is_Build_In_Place_Function | |
1280 | (Return_Applies_To (Entity (Id))); | |
1281 | ||
6f21ed26 | 1282 | -- Normal processing with HSS present |
fbf5a39b | 1283 | |
6f21ed26 RD |
1284 | declare |
1285 | EH : constant List_Id := Exception_Handlers (HSS); | |
1286 | Ent : Entity_Id := Empty; | |
1287 | S : Entity_Id; | |
fbf5a39b | 1288 | |
6f21ed26 RD |
1289 | Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; |
1290 | -- Recursively save value of this global, will be restored on exit | |
fbf5a39b | 1291 | |
6f21ed26 RD |
1292 | begin |
1293 | -- Initialize unblocked exit count for statements of begin block | |
f3d57416 | 1294 | -- plus one for each exception handler that is present. |
6f21ed26 RD |
1295 | |
1296 | Unblocked_Exit_Count := 1; | |
1297 | ||
1298 | if Present (EH) then | |
1299 | Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH); | |
996ae0b0 RK |
1300 | end if; |
1301 | ||
6f21ed26 | 1302 | -- If a label is present analyze it and mark it as referenced |
996ae0b0 | 1303 | |
6f21ed26 RD |
1304 | if Present (Id) then |
1305 | Analyze (Id); | |
1306 | Ent := Entity (Id); | |
996ae0b0 | 1307 | |
176dadf6 AC |
1308 | -- An error defense. If we have an identifier, but no entity, then |
1309 | -- something is wrong. If previous errors, then just remove the | |
1310 | -- identifier and continue, otherwise raise an exception. | |
996ae0b0 | 1311 | |
6f21ed26 | 1312 | if No (Ent) then |
ee2ba856 AC |
1313 | Check_Error_Detected; |
1314 | Set_Identifier (N, Empty); | |
996ae0b0 | 1315 | |
6f21ed26 RD |
1316 | else |
1317 | Set_Ekind (Ent, E_Block); | |
1318 | Generate_Reference (Ent, N, ' '); | |
1319 | Generate_Definition (Ent); | |
996ae0b0 | 1320 | |
6f21ed26 RD |
1321 | if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then |
1322 | Set_Label_Construct (Parent (Ent), N); | |
1323 | end if; | |
1324 | end if; | |
1325 | end if; | |
996ae0b0 | 1326 | |
6f21ed26 | 1327 | -- If no entity set, create a label entity |
996ae0b0 | 1328 | |
6f21ed26 RD |
1329 | if No (Ent) then |
1330 | Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); | |
1331 | Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N))); | |
1332 | Set_Parent (Ent, N); | |
1333 | end if; | |
1334 | ||
1335 | Set_Etype (Ent, Standard_Void_Type); | |
1336 | Set_Block_Node (Ent, Identifier (N)); | |
27c489df | 1337 | Push_Scope (Ent); |
6f21ed26 | 1338 | |
0613fb33 AC |
1339 | -- The block served as an extended return statement. Ensure that any |
1340 | -- entities created during the analysis and expansion of the return | |
1341 | -- object declaration are once again visible. | |
1342 | ||
1343 | if Is_BIP_Return_Statement then | |
1344 | Install_Return_Entities (Ent); | |
1345 | end if; | |
1346 | ||
6f21ed26 RD |
1347 | if Present (Decls) then |
1348 | Analyze_Declarations (Decls); | |
1349 | Check_Completion; | |
33931112 | 1350 | Inspect_Deferred_Constant_Completion (Decls); |
6f21ed26 | 1351 | end if; |
996ae0b0 | 1352 | |
6f21ed26 RD |
1353 | Analyze (HSS); |
1354 | Process_End_Label (HSS, 'e', Ent); | |
1355 | ||
176dadf6 AC |
1356 | -- If exception handlers are present, then we indicate that enclosing |
1357 | -- scopes contain a block with handlers. We only need to mark non- | |
1358 | -- generic scopes. | |
6f21ed26 RD |
1359 | |
1360 | if Present (EH) then | |
1361 | S := Scope (Ent); | |
996ae0b0 RK |
1362 | loop |
1363 | Set_Has_Nested_Block_With_Handler (S); | |
1364 | exit when Is_Overloadable (S) | |
1365 | or else Ekind (S) = E_Package | |
fbf5a39b | 1366 | or else Is_Generic_Unit (S); |
996ae0b0 RK |
1367 | S := Scope (S); |
1368 | end loop; | |
6f21ed26 | 1369 | end if; |
996ae0b0 | 1370 | |
5e9cb404 | 1371 | Check_References (Ent); |
851e9f19 | 1372 | Update_Use_Clause_Chain; |
6f21ed26 RD |
1373 | End_Scope; |
1374 | ||
1375 | if Unblocked_Exit_Count = 0 then | |
1376 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
1377 | Check_Unreachable_Code (N); | |
1378 | else | |
1379 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
1380 | end if; | |
1381 | end; | |
996ae0b0 RK |
1382 | end Analyze_Block_Statement; |
1383 | ||
2ffcbaa5 AC |
1384 | -------------------------------- |
1385 | -- Analyze_Compound_Statement -- | |
1386 | -------------------------------- | |
1387 | ||
1388 | procedure Analyze_Compound_Statement (N : Node_Id) is | |
1389 | begin | |
1390 | Analyze_List (Actions (N)); | |
1391 | end Analyze_Compound_Statement; | |
1392 | ||
996ae0b0 RK |
1393 | ---------------------------- |
1394 | -- Analyze_Case_Statement -- | |
1395 | ---------------------------- | |
1396 | ||
1397 | procedure Analyze_Case_Statement (N : Node_Id) is | |
5d09245e AC |
1398 | Exp : Node_Id; |
1399 | Exp_Type : Entity_Id; | |
1400 | Exp_Btype : Entity_Id; | |
1401 | Last_Choice : Nat; | |
15918371 | 1402 | |
5d09245e | 1403 | Others_Present : Boolean; |
15918371 | 1404 | -- Indicates if Others was present |
996ae0b0 | 1405 | |
67ce0d7e | 1406 | pragma Warnings (Off, Last_Choice); |
15918371 | 1407 | -- Don't care about assigned value |
67ce0d7e | 1408 | |
996ae0b0 | 1409 | Statements_Analyzed : Boolean := False; |
176dadf6 AC |
1410 | -- Set True if at least some statement sequences get analyzed. If False |
1411 | -- on exit, means we had a serious error that prevented full analysis of | |
1412 | -- the case statement, and as a result it is not a good idea to output | |
1413 | -- warning messages about unreachable code. | |
996ae0b0 RK |
1414 | |
1415 | Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; | |
1416 | -- Recursively save value of this global, will be restored on exit | |
1417 | ||
1418 | procedure Non_Static_Choice_Error (Choice : Node_Id); | |
176dadf6 AC |
1419 | -- Error routine invoked by the generic instantiation below when the |
1420 | -- case statement has a non static choice. | |
996ae0b0 RK |
1421 | |
1422 | procedure Process_Statements (Alternative : Node_Id); | |
15918371 AC |
1423 | -- Analyzes the statements associated with a case alternative. Needed |
1424 | -- by instantiation below. | |
1425 | ||
1426 | package Analyze_Case_Choices is new | |
1427 | Generic_Analyze_Choices | |
1428 | (Process_Associated_Node => Process_Statements); | |
1429 | use Analyze_Case_Choices; | |
1430 | -- Instantiation of the generic choice analysis package | |
1431 | ||
1432 | package Check_Case_Choices is new | |
1433 | Generic_Check_Choices | |
1434 | (Process_Empty_Choice => No_OP, | |
996ae0b0 | 1435 | Process_Non_Static_Choice => Non_Static_Choice_Error, |
e917e3b8 | 1436 | Process_Associated_Node => No_OP); |
15918371 | 1437 | use Check_Case_Choices; |
08aa9a4a | 1438 | -- Instantiation of the generic choice processing package |
996ae0b0 RK |
1439 | |
1440 | ----------------------------- | |
1441 | -- Non_Static_Choice_Error -- | |
1442 | ----------------------------- | |
1443 | ||
1444 | procedure Non_Static_Choice_Error (Choice : Node_Id) is | |
1445 | begin | |
fbf5a39b AC |
1446 | Flag_Non_Static_Expr |
1447 | ("choice given in case statement is not static!", Choice); | |
996ae0b0 RK |
1448 | end Non_Static_Choice_Error; |
1449 | ||
1450 | ------------------------ | |
1451 | -- Process_Statements -- | |
1452 | ------------------------ | |
1453 | ||
1454 | procedure Process_Statements (Alternative : Node_Id) is | |
5d09245e AC |
1455 | Choices : constant List_Id := Discrete_Choices (Alternative); |
1456 | Ent : Entity_Id; | |
1457 | ||
996ae0b0 RK |
1458 | begin |
1459 | Unblocked_Exit_Count := Unblocked_Exit_Count + 1; | |
1460 | Statements_Analyzed := True; | |
5d09245e AC |
1461 | |
1462 | -- An interesting optimization. If the case statement expression | |
176dadf6 AC |
1463 | -- is a simple entity, then we can set the current value within an |
1464 | -- alternative if the alternative has one possible value. | |
5d09245e AC |
1465 | |
1466 | -- case N is | |
1467 | -- when 1 => alpha | |
1468 | -- when 2 | 3 => beta | |
1469 | -- when others => gamma | |
1470 | ||
176dadf6 AC |
1471 | -- Here we know that N is initially 1 within alpha, but for beta and |
1472 | -- gamma, we do not know anything more about the initial value. | |
5d09245e AC |
1473 | |
1474 | if Is_Entity_Name (Exp) then | |
1475 | Ent := Entity (Exp); | |
1476 | ||
bce79204 AC |
1477 | if Ekind_In (Ent, E_Variable, |
1478 | E_In_Out_Parameter, | |
1479 | E_Out_Parameter) | |
5d09245e AC |
1480 | then |
1481 | if List_Length (Choices) = 1 | |
1482 | and then Nkind (First (Choices)) in N_Subexpr | |
1483 | and then Compile_Time_Known_Value (First (Choices)) | |
1484 | then | |
1485 | Set_Current_Value (Entity (Exp), First (Choices)); | |
1486 | end if; | |
1487 | ||
1488 | Analyze_Statements (Statements (Alternative)); | |
1489 | ||
1490 | -- After analyzing the case, set the current value to empty | |
1491 | -- since we won't know what it is for the next alternative | |
1492 | -- (unless reset by this same circuit), or after the case. | |
1493 | ||
1494 | Set_Current_Value (Entity (Exp), Empty); | |
1495 | return; | |
1496 | end if; | |
1497 | end if; | |
1498 | ||
1499 | -- Case where expression is not an entity name of a variable | |
1500 | ||
996ae0b0 RK |
1501 | Analyze_Statements (Statements (Alternative)); |
1502 | end Process_Statements; | |
1503 | ||
996ae0b0 RK |
1504 | -- Start of processing for Analyze_Case_Statement |
1505 | ||
1506 | begin | |
1507 | Unblocked_Exit_Count := 0; | |
1508 | Exp := Expression (N); | |
d8db0bca JM |
1509 | Analyze (Exp); |
1510 | ||
1511 | -- The expression must be of any discrete type. In rare cases, the | |
1512 | -- expander constructs a case statement whose expression has a private | |
1513 | -- type whose full view is discrete. This can happen when generating | |
1514 | -- a stream operation for a variant type after the type is frozen, | |
1515 | -- when the partial of view of the type of the discriminant is private. | |
1516 | -- In that case, use the full view to analyze case alternatives. | |
1517 | ||
1518 | if not Is_Overloaded (Exp) | |
1519 | and then not Comes_From_Source (N) | |
1520 | and then Is_Private_Type (Etype (Exp)) | |
1521 | and then Present (Full_View (Etype (Exp))) | |
1522 | and then Is_Discrete_Type (Full_View (Etype (Exp))) | |
1523 | then | |
1524 | Resolve (Exp, Etype (Exp)); | |
1525 | Exp_Type := Full_View (Etype (Exp)); | |
1526 | ||
1527 | else | |
1528 | Analyze_And_Resolve (Exp, Any_Discrete); | |
1529 | Exp_Type := Etype (Exp); | |
1530 | end if; | |
1531 | ||
996ae0b0 | 1532 | Check_Unset_Reference (Exp); |
996ae0b0 RK |
1533 | Exp_Btype := Base_Type (Exp_Type); |
1534 | ||
1535 | -- The expression must be of a discrete type which must be determinable | |
1536 | -- independently of the context in which the expression occurs, but | |
1537 | -- using the fact that the expression must be of a discrete type. | |
1538 | -- Moreover, the type this expression must not be a character literal | |
1539 | -- (which is always ambiguous) or, for Ada-83, a generic formal type. | |
1540 | ||
1541 | -- If error already reported by Resolve, nothing more to do | |
1542 | ||
15918371 | 1543 | if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then |
996ae0b0 RK |
1544 | return; |
1545 | ||
1546 | elsif Exp_Btype = Any_Character then | |
1547 | Error_Msg_N | |
1548 | ("character literal as case expression is ambiguous", Exp); | |
1549 | return; | |
1550 | ||
0ab80019 | 1551 | elsif Ada_Version = Ada_83 |
996ae0b0 | 1552 | and then (Is_Generic_Type (Exp_Btype) |
ac7d724d | 1553 | or else Is_Generic_Type (Root_Type (Exp_Btype))) |
996ae0b0 RK |
1554 | then |
1555 | Error_Msg_N | |
1556 | ("(Ada 83) case expression cannot be of a generic type", Exp); | |
1557 | return; | |
1558 | end if; | |
1559 | ||
176dadf6 AC |
1560 | -- If the case expression is a formal object of mode in out, then treat |
1561 | -- it as having a nonstatic subtype by forcing use of the base type | |
1562 | -- (which has to get passed to Check_Case_Choices below). Also use base | |
1563 | -- type when the case expression is parenthesized. | |
996ae0b0 RK |
1564 | |
1565 | if Paren_Count (Exp) > 0 | |
1566 | or else (Is_Entity_Name (Exp) | |
1567 | and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter) | |
1568 | then | |
1569 | Exp_Type := Exp_Btype; | |
1570 | end if; | |
1571 | ||
15918371 | 1572 | -- Call instantiated procedures to analyzwe and check discrete choices |
996ae0b0 | 1573 | |
15918371 AC |
1574 | Analyze_Choices (Alternatives (N), Exp_Type); |
1575 | Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); | |
996ae0b0 RK |
1576 | |
1577 | if Exp_Type = Universal_Integer and then not Others_Present then | |
1578 | Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); | |
1579 | end if; | |
1580 | ||
1581 | -- If all our exits were blocked by unconditional transfers of control, | |
1582 | -- then the entire CASE statement acts as an unconditional transfer of | |
1583 | -- control, so treat it like one, and check unreachable code. Skip this | |
1584 | -- test if we had serious errors preventing any statement analysis. | |
1585 | ||
1586 | if Unblocked_Exit_Count = 0 and then Statements_Analyzed then | |
1587 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
1588 | Check_Unreachable_Code (N); | |
1589 | else | |
1590 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
1591 | end if; | |
fbf5a39b | 1592 | |
15918371 AC |
1593 | -- If the expander is active it will detect the case of a statically |
1594 | -- determined single alternative and remove warnings for the case, but | |
1595 | -- if we are not doing expansion, that circuit won't be active. Here we | |
1596 | -- duplicate the effect of removing warnings in the same way, so that | |
1597 | -- we will get the same set of warnings in -gnatc mode. | |
1598 | ||
fbf5a39b AC |
1599 | if not Expander_Active |
1600 | and then Compile_Time_Known_Value (Expression (N)) | |
1601 | and then Serious_Errors_Detected = 0 | |
1602 | then | |
1603 | declare | |
91b1417d | 1604 | Chosen : constant Node_Id := Find_Static_Alternative (N); |
fbf5a39b AC |
1605 | Alt : Node_Id; |
1606 | ||
1607 | begin | |
1608 | Alt := First (Alternatives (N)); | |
fbf5a39b AC |
1609 | while Present (Alt) loop |
1610 | if Alt /= Chosen then | |
1611 | Remove_Warning_Messages (Statements (Alt)); | |
1612 | end if; | |
1613 | ||
1614 | Next (Alt); | |
1615 | end loop; | |
1616 | end; | |
1617 | end if; | |
996ae0b0 RK |
1618 | end Analyze_Case_Statement; |
1619 | ||
1620 | ---------------------------- | |
1621 | -- Analyze_Exit_Statement -- | |
1622 | ---------------------------- | |
1623 | ||
1624 | -- If the exit includes a name, it must be the name of a currently open | |
176dadf6 AC |
1625 | -- loop. Otherwise there must be an innermost open loop on the stack, to |
1626 | -- which the statement implicitly refers. | |
996ae0b0 | 1627 | |
ad05f2e9 | 1628 | -- Additionally, in SPARK mode: |
176dadf6 AC |
1629 | |
1630 | -- The exit can only name the closest enclosing loop; | |
1631 | ||
1632 | -- An exit with a when clause must be directly contained in a loop; | |
1633 | ||
1634 | -- An exit without a when clause must be directly contained in an | |
607d0635 AC |
1635 | -- if-statement with no elsif or else, which is itself directly contained |
1636 | -- in a loop. The exit must be the last statement in the if-statement. | |
1637 | ||
996ae0b0 RK |
1638 | procedure Analyze_Exit_Statement (N : Node_Id) is |
1639 | Target : constant Node_Id := Name (N); | |
1640 | Cond : constant Node_Id := Condition (N); | |
85be939e | 1641 | Scope_Id : Entity_Id := Empty; -- initialize to prevent warning |
996ae0b0 RK |
1642 | U_Name : Entity_Id; |
1643 | Kind : Entity_Kind; | |
1644 | ||
1645 | begin | |
1646 | if No (Cond) then | |
1647 | Check_Unreachable_Code (N); | |
1648 | end if; | |
1649 | ||
1650 | if Present (Target) then | |
1651 | Analyze (Target); | |
1652 | U_Name := Entity (Target); | |
1653 | ||
1654 | if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then | |
1655 | Error_Msg_N ("invalid loop name in exit statement", N); | |
1656 | return; | |
176dadf6 | 1657 | |
996ae0b0 RK |
1658 | else |
1659 | Set_Has_Exit (U_Name); | |
1660 | end if; | |
176dadf6 | 1661 | |
996ae0b0 RK |
1662 | else |
1663 | U_Name := Empty; | |
1664 | end if; | |
1665 | ||
1666 | for J in reverse 0 .. Scope_Stack.Last loop | |
1667 | Scope_Id := Scope_Stack.Table (J).Entity; | |
1668 | Kind := Ekind (Scope_Id); | |
1669 | ||
ac7d724d | 1670 | if Kind = E_Loop and then (No (Target) or else Scope_Id = U_Name) then |
996ae0b0 RK |
1671 | Set_Has_Exit (Scope_Id); |
1672 | exit; | |
1673 | ||
2a806772 RD |
1674 | elsif Kind = E_Block |
1675 | or else Kind = E_Loop | |
1676 | or else Kind = E_Return_Statement | |
1677 | then | |
996ae0b0 RK |
1678 | null; |
1679 | ||
1680 | else | |
1681 | Error_Msg_N | |
1682 | ("cannot exit from program unit or accept statement", N); | |
3f165ff2 | 1683 | return; |
996ae0b0 RK |
1684 | end if; |
1685 | end loop; | |
1686 | ||
08aa9a4a | 1687 | -- Verify that if present the condition is a Boolean expression |
996ae0b0 RK |
1688 | |
1689 | if Present (Cond) then | |
1690 | Analyze_And_Resolve (Cond, Any_Boolean); | |
1691 | Check_Unset_Reference (Cond); | |
1692 | end if; | |
4e7a4f6e | 1693 | |
51bf9bdf AC |
1694 | -- Chain exit statement to associated loop entity |
1695 | ||
1696 | Set_Next_Exit_Statement (N, First_Exit_Statement (Scope_Id)); | |
1697 | Set_First_Exit_Statement (Scope_Id, N); | |
1698 | ||
4e7a4f6e AC |
1699 | -- Since the exit may take us out of a loop, any previous assignment |
1700 | -- statement is not useless, so clear last assignment indications. It | |
1701 | -- is OK to keep other current values, since if the exit statement | |
1702 | -- does not exit, then the current values are still valid. | |
1703 | ||
1704 | Kill_Current_Values (Last_Assignment_Only => True); | |
996ae0b0 RK |
1705 | end Analyze_Exit_Statement; |
1706 | ||
1707 | ---------------------------- | |
1708 | -- Analyze_Goto_Statement -- | |
1709 | ---------------------------- | |
1710 | ||
1711 | procedure Analyze_Goto_Statement (N : Node_Id) is | |
1712 | Label : constant Node_Id := Name (N); | |
1713 | Scope_Id : Entity_Id; | |
1714 | Label_Scope : Entity_Id; | |
b6a1a16f | 1715 | Label_Ent : Entity_Id; |
996ae0b0 RK |
1716 | |
1717 | begin | |
607d0635 AC |
1718 | -- Actual semantic checks |
1719 | ||
996ae0b0 | 1720 | Check_Unreachable_Code (N); |
67ce0d7e | 1721 | Kill_Current_Values (Last_Assignment_Only => True); |
996ae0b0 RK |
1722 | |
1723 | Analyze (Label); | |
b6a1a16f ES |
1724 | Label_Ent := Entity (Label); |
1725 | ||
1726 | -- Ignore previous error | |
996ae0b0 | 1727 | |
b6a1a16f | 1728 | if Label_Ent = Any_Id then |
ee2ba856 | 1729 | Check_Error_Detected; |
996ae0b0 RK |
1730 | return; |
1731 | ||
b6a1a16f ES |
1732 | -- We just have a label as the target of a goto |
1733 | ||
1734 | elsif Ekind (Label_Ent) /= E_Label then | |
996ae0b0 RK |
1735 | Error_Msg_N ("target of goto statement must be a label", Label); |
1736 | return; | |
1737 | ||
b6a1a16f ES |
1738 | -- Check that the target of the goto is reachable according to Ada |
1739 | -- scoping rules. Note: the special gotos we generate for optimizing | |
1740 | -- local handling of exceptions would violate these rules, but we mark | |
1741 | -- such gotos as analyzed when built, so this code is never entered. | |
1742 | ||
1743 | elsif not Reachable (Label_Ent) then | |
996ae0b0 RK |
1744 | Error_Msg_N ("target of goto statement is not reachable", Label); |
1745 | return; | |
1746 | end if; | |
1747 | ||
b6a1a16f ES |
1748 | -- Here if goto passes initial validity checks |
1749 | ||
1750 | Label_Scope := Enclosing_Scope (Label_Ent); | |
996ae0b0 RK |
1751 | |
1752 | for J in reverse 0 .. Scope_Stack.Last loop | |
1753 | Scope_Id := Scope_Stack.Table (J).Entity; | |
1754 | ||
1755 | if Label_Scope = Scope_Id | |
ac7d724d | 1756 | or else not Ekind_In (Scope_Id, E_Block, E_Loop, E_Return_Statement) |
996ae0b0 RK |
1757 | then |
1758 | if Scope_Id /= Label_Scope then | |
1759 | Error_Msg_N | |
1760 | ("cannot exit from program unit or accept statement", N); | |
1761 | end if; | |
1762 | ||
1763 | return; | |
1764 | end if; | |
1765 | end loop; | |
1766 | ||
1767 | raise Program_Error; | |
996ae0b0 RK |
1768 | end Analyze_Goto_Statement; |
1769 | ||
1770 | -------------------------- | |
1771 | -- Analyze_If_Statement -- | |
1772 | -------------------------- | |
1773 | ||
e2d6a9e5 | 1774 | -- A special complication arises in the analysis of if statements |
fbf5a39b | 1775 | |
176dadf6 AC |
1776 | -- The expander has circuitry to completely delete code that it can tell |
1777 | -- will not be executed (as a result of compile time known conditions). In | |
ac7d724d ES |
1778 | -- the analyzer, we ensure that code that will be deleted in this manner |
1779 | -- is analyzed but not expanded. This is obviously more efficient, but | |
1780 | -- more significantly, difficulties arise if code is expanded and then | |
176dadf6 AC |
1781 | -- eliminated (e.g. exception table entries disappear). Similarly, itypes |
1782 | -- generated in deleted code must be frozen from start, because the nodes | |
1783 | -- on which they depend will not be available at the freeze point. | |
996ae0b0 RK |
1784 | |
1785 | procedure Analyze_If_Statement (N : Node_Id) is | |
1786 | E : Node_Id; | |
1787 | ||
1788 | Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; | |
1789 | -- Recursively save value of this global, will be restored on exit | |
1790 | ||
a6b13d32 | 1791 | Save_In_Deleted_Code : Boolean := In_Deleted_Code; |
fbf5a39b | 1792 | |
996ae0b0 | 1793 | Del : Boolean := False; |
176dadf6 AC |
1794 | -- This flag gets set True if a True condition has been found, which |
1795 | -- means that remaining ELSE/ELSIF parts are deleted. | |
996ae0b0 RK |
1796 | |
1797 | procedure Analyze_Cond_Then (Cnode : Node_Id); | |
176dadf6 AC |
1798 | -- This is applied to either the N_If_Statement node itself or to an |
1799 | -- N_Elsif_Part node. It deals with analyzing the condition and the THEN | |
1800 | -- statements associated with it. | |
996ae0b0 | 1801 | |
fbf5a39b AC |
1802 | ----------------------- |
1803 | -- Analyze_Cond_Then -- | |
1804 | ----------------------- | |
1805 | ||
996ae0b0 RK |
1806 | procedure Analyze_Cond_Then (Cnode : Node_Id) is |
1807 | Cond : constant Node_Id := Condition (Cnode); | |
1808 | Tstm : constant List_Id := Then_Statements (Cnode); | |
1809 | ||
1810 | begin | |
1811 | Unblocked_Exit_Count := Unblocked_Exit_Count + 1; | |
1812 | Analyze_And_Resolve (Cond, Any_Boolean); | |
1813 | Check_Unset_Reference (Cond); | |
2a806772 | 1814 | Set_Current_Value_Condition (Cnode); |
996ae0b0 RK |
1815 | |
1816 | -- If already deleting, then just analyze then statements | |
1817 | ||
1818 | if Del then | |
1819 | Analyze_Statements (Tstm); | |
1820 | ||
1821 | -- Compile time known value, not deleting yet | |
1822 | ||
1823 | elsif Compile_Time_Known_Value (Cond) then | |
fbf5a39b | 1824 | Save_In_Deleted_Code := In_Deleted_Code; |
996ae0b0 | 1825 | |
176dadf6 AC |
1826 | -- If condition is True, then analyze the THEN statements and set |
1827 | -- no expansion for ELSE and ELSIF parts. | |
996ae0b0 RK |
1828 | |
1829 | if Is_True (Expr_Value (Cond)) then | |
1830 | Analyze_Statements (Tstm); | |
1831 | Del := True; | |
1832 | Expander_Mode_Save_And_Set (False); | |
fbf5a39b | 1833 | In_Deleted_Code := True; |
996ae0b0 RK |
1834 | |
1835 | -- If condition is False, analyze THEN with expansion off | |
1836 | ||
1837 | else -- Is_False (Expr_Value (Cond)) | |
1838 | Expander_Mode_Save_And_Set (False); | |
fbf5a39b | 1839 | In_Deleted_Code := True; |
996ae0b0 RK |
1840 | Analyze_Statements (Tstm); |
1841 | Expander_Mode_Restore; | |
fbf5a39b | 1842 | In_Deleted_Code := Save_In_Deleted_Code; |
996ae0b0 RK |
1843 | end if; |
1844 | ||
1845 | -- Not known at compile time, not deleting, normal analysis | |
1846 | ||
1847 | else | |
1848 | Analyze_Statements (Tstm); | |
1849 | end if; | |
1850 | end Analyze_Cond_Then; | |
1851 | ||
704228bd | 1852 | -- Start of processing for Analyze_If_Statement |
996ae0b0 RK |
1853 | |
1854 | begin | |
176dadf6 AC |
1855 | -- Initialize exit count for else statements. If there is no else part, |
1856 | -- this count will stay non-zero reflecting the fact that the uncovered | |
1857 | -- else case is an unblocked exit. | |
996ae0b0 RK |
1858 | |
1859 | Unblocked_Exit_Count := 1; | |
1860 | Analyze_Cond_Then (N); | |
1861 | ||
1862 | -- Now to analyze the elsif parts if any are present | |
1863 | ||
1864 | if Present (Elsif_Parts (N)) then | |
1865 | E := First (Elsif_Parts (N)); | |
1866 | while Present (E) loop | |
1867 | Analyze_Cond_Then (E); | |
1868 | Next (E); | |
1869 | end loop; | |
1870 | end if; | |
1871 | ||
1872 | if Present (Else_Statements (N)) then | |
1873 | Analyze_Statements (Else_Statements (N)); | |
1874 | end if; | |
1875 | ||
1876 | -- If all our exits were blocked by unconditional transfers of control, | |
1877 | -- then the entire IF statement acts as an unconditional transfer of | |
1878 | -- control, so treat it like one, and check unreachable code. | |
1879 | ||
1880 | if Unblocked_Exit_Count = 0 then | |
1881 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
1882 | Check_Unreachable_Code (N); | |
1883 | else | |
1884 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
1885 | end if; | |
1886 | ||
1887 | if Del then | |
1888 | Expander_Mode_Restore; | |
fbf5a39b | 1889 | In_Deleted_Code := Save_In_Deleted_Code; |
996ae0b0 RK |
1890 | end if; |
1891 | ||
fbf5a39b AC |
1892 | if not Expander_Active |
1893 | and then Compile_Time_Known_Value (Condition (N)) | |
1894 | and then Serious_Errors_Detected = 0 | |
1895 | then | |
1896 | if Is_True (Expr_Value (Condition (N))) then | |
1897 | Remove_Warning_Messages (Else_Statements (N)); | |
1898 | ||
1899 | if Present (Elsif_Parts (N)) then | |
1900 | E := First (Elsif_Parts (N)); | |
fbf5a39b AC |
1901 | while Present (E) loop |
1902 | Remove_Warning_Messages (Then_Statements (E)); | |
1903 | Next (E); | |
1904 | end loop; | |
1905 | end if; | |
1906 | ||
1907 | else | |
1908 | Remove_Warning_Messages (Then_Statements (N)); | |
1909 | end if; | |
1910 | end if; | |
82893775 AC |
1911 | |
1912 | -- Warn on redundant if statement that has no effect | |
1913 | ||
08988ed9 AC |
1914 | -- Note, we could also check empty ELSIF parts ??? |
1915 | ||
82893775 AC |
1916 | if Warn_On_Redundant_Constructs |
1917 | ||
08988ed9 AC |
1918 | -- If statement must be from source |
1919 | ||
1920 | and then Comes_From_Source (N) | |
1921 | ||
82893775 AC |
1922 | -- Condition must not have obvious side effect |
1923 | ||
1924 | and then Has_No_Obvious_Side_Effects (Condition (N)) | |
1925 | ||
1926 | -- No elsif parts of else part | |
1927 | ||
1928 | and then No (Elsif_Parts (N)) | |
1929 | and then No (Else_Statements (N)) | |
1930 | ||
1931 | -- Then must be a single null statement | |
1932 | ||
1933 | and then List_Length (Then_Statements (N)) = 1 | |
1934 | then | |
1935 | -- Go to original node, since we may have rewritten something as | |
1936 | -- a null statement (e.g. a case we could figure the outcome of). | |
1937 | ||
1938 | declare | |
1939 | T : constant Node_Id := First (Then_Statements (N)); | |
1940 | S : constant Node_Id := Original_Node (T); | |
1941 | ||
1942 | begin | |
1943 | if Comes_From_Source (S) and then Nkind (S) = N_Null_Statement then | |
1944 | Error_Msg_N ("if statement has no effect?r?", N); | |
1945 | end if; | |
1946 | end; | |
1947 | end if; | |
996ae0b0 RK |
1948 | end Analyze_If_Statement; |
1949 | ||
1950 | ---------------------------------------- | |
1951 | -- Analyze_Implicit_Label_Declaration -- | |
1952 | ---------------------------------------- | |
1953 | ||
176dadf6 AC |
1954 | -- An implicit label declaration is generated in the innermost enclosing |
1955 | -- declarative part. This is done for labels, and block and loop names. | |
996ae0b0 RK |
1956 | |
1957 | -- Note: any changes in this routine may need to be reflected in | |
1958 | -- Analyze_Label_Entity. | |
1959 | ||
1960 | procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is | |
fbf5a39b | 1961 | Id : constant Node_Id := Defining_Identifier (N); |
996ae0b0 | 1962 | begin |
fbf5a39b | 1963 | Enter_Name (Id); |
996ae0b0 RK |
1964 | Set_Ekind (Id, E_Label); |
1965 | Set_Etype (Id, Standard_Void_Type); | |
1966 | Set_Enclosing_Scope (Id, Current_Scope); | |
1967 | end Analyze_Implicit_Label_Declaration; | |
1968 | ||
1969 | ------------------------------ | |
1970 | -- Analyze_Iteration_Scheme -- | |
1971 | ------------------------------ | |
1972 | ||
1973 | procedure Analyze_Iteration_Scheme (N : Node_Id) is | |
804670f1 AC |
1974 | Cond : Node_Id; |
1975 | Iter_Spec : Node_Id; | |
1976 | Loop_Spec : Node_Id; | |
ffe9aba8 | 1977 | |
804670f1 AC |
1978 | begin |
1979 | -- For an infinite loop, there is no iteration scheme | |
ffe9aba8 | 1980 | |
804670f1 AC |
1981 | if No (N) then |
1982 | return; | |
1983 | end if; | |
9596236a | 1984 | |
804670f1 AC |
1985 | Cond := Condition (N); |
1986 | Iter_Spec := Iterator_Specification (N); | |
1987 | Loop_Spec := Loop_Parameter_Specification (N); | |
176dadf6 | 1988 | |
804670f1 AC |
1989 | if Present (Cond) then |
1990 | Analyze_And_Resolve (Cond, Any_Boolean); | |
1991 | Check_Unset_Reference (Cond); | |
1992 | Set_Current_Value_Condition (N); | |
ffe9aba8 | 1993 | |
804670f1 AC |
1994 | elsif Present (Iter_Spec) then |
1995 | Analyze_Iterator_Specification (Iter_Spec); | |
ffe9aba8 | 1996 | |
804670f1 AC |
1997 | else |
1998 | Analyze_Loop_Parameter_Specification (Loop_Spec); | |
1999 | end if; | |
2000 | end Analyze_Iteration_Scheme; | |
ffe9aba8 | 2001 | |
804670f1 AC |
2002 | ------------------------------------ |
2003 | -- Analyze_Iterator_Specification -- | |
2004 | ------------------------------------ | |
ffe9aba8 | 2005 | |
804670f1 | 2006 | procedure Analyze_Iterator_Specification (N : Node_Id) is |
162ea0d3 HK |
2007 | Def_Id : constant Node_Id := Defining_Identifier (N); |
2008 | Iter_Name : constant Node_Id := Name (N); | |
2009 | Loc : constant Source_Ptr := Sloc (N); | |
2010 | Subt : constant Node_Id := Subtype_Indication (N); | |
2011 | ||
2012 | Bas : Entity_Id := Empty; -- initialize to prevent warning | |
2013 | Typ : Entity_Id; | |
2014 | ||
7a5b62b0 AC |
2015 | procedure Check_Reverse_Iteration (Typ : Entity_Id); |
2016 | -- For an iteration over a container, if the loop carries the Reverse | |
2017 | -- indicator, verify that the container type has an Iterate aspect that | |
2018 | -- implements the reversible iterator interface. | |
2019 | ||
ac450fb2 ES |
2020 | procedure Check_Subtype_Indication (Comp_Type : Entity_Id); |
2021 | -- If a subtype indication is present, verify that it is consistent | |
2022 | -- with the component type of the array or container name. | |
2023 | ||
cad97339 | 2024 | function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id; |
1ca46a77 AC |
2025 | -- For containers with Iterator and related aspects, the cursor is |
2026 | -- obtained by locating an entity with the proper name in the scope | |
2027 | -- of the type. | |
cad97339 | 2028 | |
7a5b62b0 AC |
2029 | ----------------------------- |
2030 | -- Check_Reverse_Iteration -- | |
2031 | ----------------------------- | |
2032 | ||
2033 | procedure Check_Reverse_Iteration (Typ : Entity_Id) is | |
2034 | begin | |
367601d1 PMR |
2035 | if Reverse_Present (N) then |
2036 | if Is_Array_Type (Typ) | |
2037 | or else Is_Reversible_Iterator (Typ) | |
2038 | or else | |
3fc40cd7 PMR |
2039 | (Present (Find_Aspect (Typ, Aspect_Iterable)) |
2040 | and then | |
2041 | Present | |
367601d1 PMR |
2042 | (Get_Iterable_Type_Primitive (Typ, Name_Previous))) |
2043 | then | |
2044 | null; | |
2045 | else | |
2046 | Error_Msg_NE | |
2047 | ("container type does not support reverse iteration", N, Typ); | |
2048 | end if; | |
7a5b62b0 AC |
2049 | end if; |
2050 | end Check_Reverse_Iteration; | |
2051 | ||
ac450fb2 ES |
2052 | ------------------------------- |
2053 | -- Check_Subtype_Indication -- | |
2054 | ------------------------------- | |
2055 | ||
2056 | procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is | |
2057 | begin | |
2058 | if Present (Subt) | |
2059 | and then (not Covers (Base_Type ((Bas)), Comp_Type) | |
2060 | or else not Subtypes_Statically_Match (Bas, Comp_Type)) | |
2061 | then | |
2062 | if Is_Array_Type (Typ) then | |
2063 | Error_Msg_N | |
2064 | ("subtype indication does not match component type", Subt); | |
2065 | else | |
2066 | Error_Msg_N | |
2067 | ("subtype indication does not match element type", Subt); | |
2068 | end if; | |
2069 | end if; | |
2070 | end Check_Subtype_Indication; | |
2071 | ||
cad97339 AC |
2072 | --------------------- |
2073 | -- Get_Cursor_Type -- | |
2074 | --------------------- | |
2075 | ||
2076 | function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is | |
2077 | Ent : Entity_Id; | |
2078 | ||
2079 | begin | |
ad81cb78 AC |
2080 | -- If iterator type is derived, the cursor is declared in the scope |
2081 | -- of the parent type. | |
2082 | ||
2083 | if Is_Derived_Type (Typ) then | |
2084 | Ent := First_Entity (Scope (Etype (Typ))); | |
2085 | else | |
2086 | Ent := First_Entity (Scope (Typ)); | |
2087 | end if; | |
2088 | ||
cad97339 AC |
2089 | while Present (Ent) loop |
2090 | exit when Chars (Ent) = Name_Cursor; | |
2091 | Next_Entity (Ent); | |
2092 | end loop; | |
2093 | ||
2094 | if No (Ent) then | |
2095 | return Any_Type; | |
2096 | end if; | |
2097 | ||
2098 | -- The cursor is the target of generated assignments in the | |
2099 | -- loop, and cannot have a limited type. | |
2100 | ||
2101 | if Is_Limited_Type (Etype (Ent)) then | |
2102 | Error_Msg_N ("cursor type cannot be limited", N); | |
2103 | end if; | |
2104 | ||
2105 | return Etype (Ent); | |
2106 | end Get_Cursor_Type; | |
2107 | ||
1e60643a | 2108 | -- Start of processing for Analyze_Iterator_Specification |
7a5b62b0 | 2109 | |
804670f1 AC |
2110 | begin |
2111 | Enter_Name (Def_Id); | |
98123480 | 2112 | |
7858300e AC |
2113 | -- AI12-0151 specifies that when the subtype indication is present, it |
2114 | -- must statically match the type of the array or container element. | |
2115 | -- To simplify this check, we introduce a subtype declaration with the | |
2116 | -- given subtype indication when it carries a constraint, and rewrite | |
2117 | -- the original as a reference to the created subtype entity. | |
d0ef7921 | 2118 | |
7858300e | 2119 | if Present (Subt) then |
d0ef7921 | 2120 | if Nkind (Subt) = N_Subtype_Indication then |
7858300e AC |
2121 | declare |
2122 | S : constant Entity_Id := Make_Temporary (Sloc (Subt), 'S'); | |
2123 | Decl : constant Node_Id := | |
2124 | Make_Subtype_Declaration (Loc, | |
2125 | Defining_Identifier => S, | |
2126 | Subtype_Indication => New_Copy_Tree (Subt)); | |
2127 | begin | |
2128 | Insert_Before (Parent (Parent (N)), Decl); | |
2129 | Analyze (Decl); | |
2130 | Rewrite (Subt, New_Occurrence_Of (S, Sloc (Subt))); | |
2131 | end; | |
d0ef7921 | 2132 | else |
7858300e | 2133 | Analyze (Subt); |
d0ef7921 | 2134 | end if; |
7858300e AC |
2135 | |
2136 | -- Save entity of subtype indication for subsequent check | |
2137 | ||
2138 | Bas := Entity (Subt); | |
804670f1 | 2139 | end if; |
ffe9aba8 | 2140 | |
804670f1 | 2141 | Preanalyze_Range (Iter_Name); |
c9626ed6 | 2142 | |
b45a9ff3 JS |
2143 | -- If the domain of iteration is a function call, make sure the function |
2144 | -- itself is frozen. This is an issue if this is a local expression | |
2145 | -- function. | |
2146 | ||
2147 | if Nkind (Iter_Name) = N_Function_Call | |
2148 | and then Is_Entity_Name (Name (Iter_Name)) | |
2149 | and then Full_Analysis | |
dd81163f | 2150 | and then (In_Assertion_Expr = 0 or else Assertions_Enabled) |
b45a9ff3 JS |
2151 | then |
2152 | Freeze_Before (N, Entity (Name (Iter_Name))); | |
2153 | end if; | |
2154 | ||
5e9cb404 AC |
2155 | -- Set the kind of the loop variable, which is not visible within the |
2156 | -- iterator name. | |
b25ce290 ES |
2157 | |
2158 | Set_Ekind (Def_Id, E_Variable); | |
2159 | ||
818b578d AC |
2160 | -- Provide a link between the iterator variable and the container, for |
2161 | -- subsequent use in cross-reference and modification information. | |
c2e54001 AC |
2162 | |
2163 | if Of_Present (N) then | |
2164 | Set_Related_Expression (Def_Id, Iter_Name); | |
7a5b62b0 | 2165 | |
7858300e | 2166 | -- For a container, the iterator is specified through the aspect |
7a5b62b0 AC |
2167 | |
2168 | if not Is_Array_Type (Etype (Iter_Name)) then | |
2169 | declare | |
2170 | Iterator : constant Entity_Id := | |
78f8727c RD |
2171 | Find_Value_Of_Aspect |
2172 | (Etype (Iter_Name), Aspect_Default_Iterator); | |
2173 | ||
7a5b62b0 AC |
2174 | I : Interp_Index; |
2175 | It : Interp; | |
2176 | ||
2177 | begin | |
31fde973 | 2178 | -- The domain of iteration must implement either the RM |
c910db71 ES |
2179 | -- iterator interface, or the SPARK Iterable aspect. |
2180 | ||
7a5b62b0 | 2181 | if No (Iterator) then |
31fde973 GD |
2182 | if No (Find_Aspect (Etype (Iter_Name), Aspect_Iterable)) then |
2183 | Error_Msg_NE | |
2184 | ("cannot iterate over&", | |
2185 | N, Base_Type (Etype (Iter_Name))); | |
c910db71 ES |
2186 | return; |
2187 | end if; | |
7a5b62b0 AC |
2188 | |
2189 | elsif not Is_Overloaded (Iterator) then | |
2190 | Check_Reverse_Iteration (Etype (Iterator)); | |
2191 | ||
90e491a7 PMR |
2192 | -- If Iterator is overloaded, use reversible iterator if one is |
2193 | -- available. | |
7a5b62b0 AC |
2194 | |
2195 | elsif Is_Overloaded (Iterator) then | |
2196 | Get_First_Interp (Iterator, I, It); | |
2197 | while Present (It.Nam) loop | |
2198 | if Ekind (It.Nam) = E_Function | |
2199 | and then Is_Reversible_Iterator (Etype (It.Nam)) | |
2200 | then | |
2201 | Set_Etype (Iterator, It.Typ); | |
2202 | Set_Entity (Iterator, It.Nam); | |
2203 | exit; | |
2204 | end if; | |
2205 | ||
2206 | Get_Next_Interp (I, It); | |
2207 | end loop; | |
2208 | ||
2209 | Check_Reverse_Iteration (Etype (Iterator)); | |
2210 | end if; | |
2211 | end; | |
2212 | end if; | |
c2e54001 AC |
2213 | end if; |
2214 | ||
804670f1 AC |
2215 | -- If the domain of iteration is an expression, create a declaration for |
2216 | -- it, so that finalization actions are introduced outside of the loop. | |
2217 | -- The declaration must be a renaming because the body of the loop may | |
f2c992d9 | 2218 | -- assign to elements. |
c9626ed6 | 2219 | |
804670f1 | 2220 | if not Is_Entity_Name (Iter_Name) |
f2c992d9 AC |
2221 | |
2222 | -- When the context is a quantified expression, the renaming | |
2223 | -- declaration is delayed until the expansion phase if we are | |
2224 | -- doing expansion. | |
2225 | ||
804670f1 | 2226 | and then (Nkind (Parent (N)) /= N_Quantified_Expression |
f2c992d9 | 2227 | or else Operating_Mode = Check_Semantics) |
36504e5f | 2228 | |
3aeb5ebe AC |
2229 | -- Do not perform this expansion when expansion is disabled, where the |
2230 | -- temporary may hide the transformation of a selected component into | |
2231 | -- a prefixed function call, and references need to see the original | |
2232 | -- expression. | |
36504e5f | 2233 | |
93e90bf4 | 2234 | and then Expander_Active |
804670f1 AC |
2235 | then |
2236 | declare | |
33ca2867 AC |
2237 | Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); |
2238 | Decl : Node_Id; | |
2239 | Act_S : Node_Id; | |
c9626ed6 | 2240 | |
804670f1 | 2241 | begin |
33ca2867 AC |
2242 | |
2243 | -- If the domain of iteration is an array component that depends | |
e8bb6ff9 | 2244 | -- on a discriminant, create actual subtype for it. Preanalysis |
33ca2867 AC |
2245 | -- does not generate the actual subtype of a selected component. |
2246 | ||
2247 | if Nkind (Iter_Name) = N_Selected_Component | |
2248 | and then Is_Array_Type (Etype (Iter_Name)) | |
2249 | then | |
2250 | Act_S := | |
2251 | Build_Actual_Subtype_Of_Component | |
2252 | (Etype (Selector_Name (Iter_Name)), Iter_Name); | |
2253 | Insert_Action (N, Act_S); | |
2254 | ||
2255 | if Present (Act_S) then | |
2256 | Typ := Defining_Identifier (Act_S); | |
2257 | else | |
2258 | Typ := Etype (Iter_Name); | |
2259 | end if; | |
2260 | ||
2261 | else | |
2262 | Typ := Etype (Iter_Name); | |
ac2ea5c5 | 2263 | |
2e215573 | 2264 | -- Verify that the expression produces an iterator |
ac2ea5c5 AC |
2265 | |
2266 | if not Of_Present (N) and then not Is_Iterator (Typ) | |
2267 | and then not Is_Array_Type (Typ) | |
2268 | and then No (Find_Aspect (Typ, Aspect_Iterable)) | |
2269 | then | |
2270 | Error_Msg_N | |
2271 | ("expect object that implements iterator interface", | |
2e215573 | 2272 | Iter_Name); |
ac2ea5c5 | 2273 | end if; |
33ca2867 | 2274 | end if; |
176dadf6 | 2275 | |
8777c5a6 | 2276 | -- Protect against malformed iterator |
b25ce290 ES |
2277 | |
2278 | if Typ = Any_Type then | |
2279 | Error_Msg_N ("invalid expression in loop iterator", Iter_Name); | |
2280 | return; | |
2281 | end if; | |
2282 | ||
7a5b62b0 AC |
2283 | if not Of_Present (N) then |
2284 | Check_Reverse_Iteration (Typ); | |
2285 | end if; | |
2286 | ||
93350089 ES |
2287 | -- For an element iteration over a slice, we must complete |
2288 | -- the resolution and expansion of the slice bounds. These | |
2289 | -- can be arbitrary expressions, and the preanalysis that | |
2290 | -- was performed in preparation for the iteration may have | |
2291 | -- generated an itype whose bounds must be fully expanded. | |
2292 | -- We set the parent node to provide a proper insertion | |
2293 | -- point for generated actions, if any. | |
2294 | ||
2295 | if Nkind (Iter_Name) = N_Slice | |
2296 | and then Nkind (Discrete_Range (Iter_Name)) = N_Range | |
2297 | and then not Analyzed (Discrete_Range (Iter_Name)) | |
2298 | then | |
2299 | declare | |
2300 | Indx : constant Node_Id := | |
2301 | Entity (First_Index (Etype (Iter_Name))); | |
2302 | begin | |
2303 | Set_Parent (Indx, Iter_Name); | |
2304 | Resolve (Scalar_Range (Indx), Etype (Indx)); | |
2305 | end; | |
2306 | end if; | |
2307 | ||
804670f1 AC |
2308 | -- The name in the renaming declaration may be a function call. |
2309 | -- Indicate that it does not come from source, to suppress | |
7b4ebba5 AC |
2310 | -- spurious warnings on renamings of parameterless functions, |
2311 | -- a common enough idiom in user-defined iterators. | |
c9626ed6 | 2312 | |
ffe9aba8 | 2313 | Decl := |
804670f1 | 2314 | Make_Object_Renaming_Declaration (Loc, |
ffe9aba8 | 2315 | Defining_Identifier => Id, |
804670f1 AC |
2316 | Subtype_Mark => New_Occurrence_Of (Typ, Loc), |
2317 | Name => | |
2318 | New_Copy_Tree (Iter_Name, New_Sloc => Loc)); | |
ffe9aba8 | 2319 | |
804670f1 AC |
2320 | Insert_Actions (Parent (Parent (N)), New_List (Decl)); |
2321 | Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); | |
2322 | Set_Etype (Id, Typ); | |
2323 | Set_Etype (Name (N), Typ); | |
2324 | end; | |
ffe9aba8 | 2325 | |
804670f1 AC |
2326 | -- Container is an entity or an array with uncontrolled components, or |
2327 | -- else it is a container iterator given by a function call, typically | |
2328 | -- called Iterate in the case of predefined containers, even though | |
f2c992d9 | 2329 | -- Iterate is not a reserved name. What matters is that the return type |
804670f1 | 2330 | -- of the function is an iterator type. |
ffe9aba8 | 2331 | |
e361e9a1 | 2332 | elsif Is_Entity_Name (Iter_Name) then |
804670f1 | 2333 | Analyze (Iter_Name); |
273adcdf | 2334 | |
804670f1 AC |
2335 | if Nkind (Iter_Name) = N_Function_Call then |
2336 | declare | |
2337 | C : constant Node_Id := Name (Iter_Name); | |
2338 | I : Interp_Index; | |
2339 | It : Interp; | |
273adcdf | 2340 | |
804670f1 AC |
2341 | begin |
2342 | if not Is_Overloaded (Iter_Name) then | |
2343 | Resolve (Iter_Name, Etype (C)); | |
ffe9aba8 | 2344 | |
804670f1 AC |
2345 | else |
2346 | Get_First_Interp (C, I, It); | |
2347 | while It.Typ /= Empty loop | |
2348 | if Reverse_Present (N) then | |
2349 | if Is_Reversible_Iterator (It.Typ) then | |
2350 | Resolve (Iter_Name, It.Typ); | |
2351 | exit; | |
2352 | end if; | |
2353 | ||
2354 | elsif Is_Iterator (It.Typ) then | |
2355 | Resolve (Iter_Name, It.Typ); | |
2356 | exit; | |
2357 | end if; | |
2358 | ||
2359 | Get_Next_Interp (I, It); | |
2360 | end loop; | |
2361 | end if; | |
2362 | end; | |
2363 | ||
2364 | -- Domain of iteration is not overloaded | |
2365 | ||
2366 | else | |
2367 | Resolve (Iter_Name, Etype (Iter_Name)); | |
2368 | end if; | |
7a5b62b0 AC |
2369 | |
2370 | if not Of_Present (N) then | |
2371 | Check_Reverse_Iteration (Etype (Iter_Name)); | |
2372 | end if; | |
804670f1 AC |
2373 | end if; |
2374 | ||
110e2969 AC |
2375 | -- Get base type of container, for proper retrieval of Cursor type |
2376 | -- and primitive operations. | |
2377 | ||
2378 | Typ := Base_Type (Etype (Iter_Name)); | |
804670f1 AC |
2379 | |
2380 | if Is_Array_Type (Typ) then | |
2381 | if Of_Present (N) then | |
2382 | Set_Etype (Def_Id, Component_Type (Typ)); | |
2383 | ||
e8c84c8f | 2384 | -- The loop variable is aliased if the array components are |
a517d6c1 | 2385 | -- aliased. Likewise for the independent aspect. |
e8c84c8f | 2386 | |
a517d6c1 EB |
2387 | Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ)); |
2388 | Set_Is_Independent (Def_Id, Has_Independent_Components (Typ)); | |
e8c84c8f | 2389 | |
90b510e4 AC |
2390 | -- AI12-0047 stipulates that the domain (array or container) |
2391 | -- cannot be a component that depends on a discriminant if the | |
2392 | -- enclosing object is mutable, to prevent a modification of the | |
63408d0e | 2393 | -- domain of iteration in the course of an iteration. |
7858300e | 2394 | |
90b510e4 AC |
2395 | -- If the object is an expression it has been captured in a |
2396 | -- temporary, so examine original node. | |
6333ad3d AC |
2397 | |
2398 | if Nkind (Original_Node (Iter_Name)) = N_Selected_Component | |
7858300e | 2399 | and then Is_Dependent_Component_Of_Mutable_Object |
6333ad3d | 2400 | (Original_Node (Iter_Name)) |
7858300e AC |
2401 | then |
2402 | Error_Msg_N | |
90b510e4 | 2403 | ("iterable name cannot be a discriminant-dependent " |
7858300e AC |
2404 | & "component of a mutable object", N); |
2405 | end if; | |
2406 | ||
ac450fb2 | 2407 | Check_Subtype_Indication (Component_Type (Typ)); |
d0ef7921 | 2408 | |
804670f1 AC |
2409 | -- Here we have a missing Range attribute |
2410 | ||
2411 | else | |
2412 | Error_Msg_N | |
2413 | ("missing Range attribute in iteration over an array", N); | |
2414 | ||
2415 | -- In Ada 2012 mode, this may be an attempt at an iterator | |
2416 | ||
2417 | if Ada_Version >= Ada_2012 then | |
2418 | Error_Msg_NE | |
2419 | ("\if& is meant to designate an element of the array, use OF", | |
7858300e | 2420 | N, Def_Id); |
ffe9aba8 | 2421 | end if; |
ffe9aba8 | 2422 | |
804670f1 | 2423 | -- Prevent cascaded errors |
ffe9aba8 | 2424 | |
804670f1 AC |
2425 | Set_Ekind (Def_Id, E_Loop_Parameter); |
2426 | Set_Etype (Def_Id, Etype (First_Index (Typ))); | |
2427 | end if; | |
bc49df98 | 2428 | |
804670f1 | 2429 | -- Check for type error in iterator |
bc49df98 | 2430 | |
804670f1 AC |
2431 | elsif Typ = Any_Type then |
2432 | return; | |
2a806772 | 2433 | |
804670f1 AC |
2434 | -- Iteration over a container |
2435 | ||
2436 | else | |
2437 | Set_Ekind (Def_Id, E_Loop_Parameter); | |
c6d2191a | 2438 | Error_Msg_Ada_2012_Feature ("container iterator", Sloc (N)); |
804670f1 | 2439 | |
ebb6b0bd AC |
2440 | -- OF present |
2441 | ||
804670f1 | 2442 | if Of_Present (N) then |
8880426d | 2443 | if Has_Aspect (Typ, Aspect_Iterable) then |
65529f74 AC |
2444 | declare |
2445 | Elt : constant Entity_Id := | |
2446 | Get_Iterable_Type_Primitive (Typ, Name_Element); | |
2447 | begin | |
2448 | if No (Elt) then | |
2449 | Error_Msg_N | |
2450 | ("missing Element primitive for iteration", N); | |
65529f74 AC |
2451 | else |
2452 | Set_Etype (Def_Id, Etype (Elt)); | |
367601d1 | 2453 | Check_Reverse_Iteration (Typ); |
65529f74 AC |
2454 | end if; |
2455 | end; | |
804670f1 | 2456 | |
ac450fb2 ES |
2457 | Check_Subtype_Indication (Etype (Def_Id)); |
2458 | ||
e8bb6ff9 | 2459 | -- For a predefined container, the type of the loop variable is |
8880426d | 2460 | -- the Iterator_Element aspect of the container type. |
804670f1 | 2461 | |
8880426d AC |
2462 | else |
2463 | declare | |
08f52d9f AC |
2464 | Element : constant Entity_Id := |
2465 | Find_Value_Of_Aspect | |
2466 | (Typ, Aspect_Iterator_Element); | |
2467 | Iterator : constant Entity_Id := | |
2468 | Find_Value_Of_Aspect | |
2469 | (Typ, Aspect_Default_Iterator); | |
2470 | Orig_Iter_Name : constant Node_Id := | |
2471 | Original_Node (Iter_Name); | |
2472 | Cursor_Type : Entity_Id; | |
ebb6b0bd | 2473 | |
8880426d AC |
2474 | begin |
2475 | if No (Element) then | |
2476 | Error_Msg_NE ("cannot iterate over&", N, Typ); | |
2477 | return; | |
ebb6b0bd | 2478 | |
8880426d AC |
2479 | else |
2480 | Set_Etype (Def_Id, Entity (Element)); | |
cad97339 AC |
2481 | Cursor_Type := Get_Cursor_Type (Typ); |
2482 | pragma Assert (Present (Cursor_Type)); | |
cb42ba5d | 2483 | |
ac450fb2 | 2484 | Check_Subtype_Indication (Etype (Def_Id)); |
d0ef7921 | 2485 | |
8880426d AC |
2486 | -- If the container has a variable indexing aspect, the |
2487 | -- element is a variable and is modifiable in the loop. | |
cb42ba5d | 2488 | |
8880426d AC |
2489 | if Has_Aspect (Typ, Aspect_Variable_Indexing) then |
2490 | Set_Ekind (Def_Id, E_Variable); | |
2491 | end if; | |
6333ad3d AC |
2492 | |
2493 | -- If the container is a constant, iterating over it | |
2494 | -- requires a Constant_Indexing operation. | |
2495 | ||
2496 | if not Is_Variable (Iter_Name) | |
2497 | and then not Has_Aspect (Typ, Aspect_Constant_Indexing) | |
2498 | then | |
08f52d9f AC |
2499 | Error_Msg_N |
2500 | ("iteration over constant container require " | |
2501 | & "constant_indexing aspect", N); | |
6333ad3d AC |
2502 | |
2503 | -- The Iterate function may have an in_out parameter, | |
2504 | -- and a constant container is thus illegal. | |
2505 | ||
2506 | elsif Present (Iterator) | |
2507 | and then Ekind (Entity (Iterator)) = E_Function | |
2508 | and then Ekind (First_Formal (Entity (Iterator))) /= | |
2509 | E_In_Parameter | |
2510 | and then not Is_Variable (Iter_Name) | |
2511 | then | |
08f52d9f | 2512 | Error_Msg_N ("variable container expected", N); |
6333ad3d AC |
2513 | end if; |
2514 | ||
2d6aa715 AC |
2515 | -- Detect a case where the iterator denotes a component |
2516 | -- of a mutable object which depends on a discriminant. | |
2517 | -- Note that the iterator may denote a function call in | |
2518 | -- qualified form, in which case this check should not | |
2519 | -- be performed. | |
08f52d9f AC |
2520 | |
2521 | if Nkind (Orig_Iter_Name) = N_Selected_Component | |
1e60643a AC |
2522 | and then |
2523 | Present (Entity (Selector_Name (Orig_Iter_Name))) | |
08f52d9f AC |
2524 | and then Ekind_In |
2525 | (Entity (Selector_Name (Orig_Iter_Name)), | |
2526 | E_Component, | |
2527 | E_Discriminant) | |
2528 | and then Is_Dependent_Component_Of_Mutable_Object | |
2529 | (Orig_Iter_Name) | |
6333ad3d AC |
2530 | then |
2531 | Error_Msg_N | |
2532 | ("container cannot be a discriminant-dependent " | |
2533 | & "component of a mutable object", N); | |
2534 | end if; | |
cb42ba5d | 2535 | end if; |
8880426d AC |
2536 | end; |
2537 | end if; | |
804670f1 | 2538 | |
7166d535 | 2539 | -- IN iterator, domain is a range, or a call to Iterate function |
ebb6b0bd | 2540 | |
804670f1 AC |
2541 | else |
2542 | -- For an iteration of the form IN, the name must denote an | |
2543 | -- iterator, typically the result of a call to Iterate. Give a | |
2544 | -- useful error message when the name is a container by itself. | |
2545 | ||
dd2bf554 ES |
2546 | -- The type may be a formal container type, which has to have |
2547 | -- an Iterable aspect detailing the required primitives. | |
2548 | ||
804670f1 AC |
2549 | if Is_Entity_Name (Original_Node (Name (N))) |
2550 | and then not Is_Iterator (Typ) | |
2a806772 | 2551 | then |
dd2bf554 ES |
2552 | if Has_Aspect (Typ, Aspect_Iterable) then |
2553 | null; | |
2554 | ||
2555 | elsif not Has_Aspect (Typ, Aspect_Iterator_Element) then | |
804670f1 AC |
2556 | Error_Msg_NE |
2557 | ("cannot iterate over&", Name (N), Typ); | |
2558 | else | |
2559 | Error_Msg_N | |
2560 | ("name must be an iterator, not a container", Name (N)); | |
2561 | end if; | |
2a806772 | 2562 | |
dd2bf554 ES |
2563 | if Has_Aspect (Typ, Aspect_Iterable) then |
2564 | null; | |
2565 | else | |
2566 | Error_Msg_NE | |
2567 | ("\to iterate directly over the elements of a container, " | |
82d4f390 | 2568 | & "write `of &`", Name (N), Original_Node (Name (N))); |
a98480dd | 2569 | |
3cb9a885 | 2570 | -- No point in continuing analysis of iterator spec |
a98480dd AC |
2571 | |
2572 | return; | |
dd2bf554 | 2573 | end if; |
2a806772 | 2574 | end if; |
804670f1 | 2575 | |
7166d535 AC |
2576 | -- If the name is a call (typically prefixed) to some Iterate |
2577 | -- function, it has been rewritten as an object declaration. | |
2578 | -- If that object is a selected component, verify that it is not | |
2579 | -- a component of an unconstrained mutable object. | |
2580 | ||
93e90bf4 AC |
2581 | if Nkind (Iter_Name) = N_Identifier |
2582 | or else (not Expander_Active and Comes_From_Source (Iter_Name)) | |
2583 | then | |
7166d535 | 2584 | declare |
93e90bf4 | 2585 | Orig_Node : constant Node_Id := Original_Node (Iter_Name); |
6333ad3d | 2586 | Iter_Kind : constant Node_Kind := Nkind (Orig_Node); |
7166d535 AC |
2587 | Obj : Node_Id; |
2588 | ||
2589 | begin | |
2590 | if Iter_Kind = N_Selected_Component then | |
6333ad3d | 2591 | Obj := Prefix (Orig_Node); |
cad97339 | 2592 | |
7166d535 | 2593 | elsif Iter_Kind = N_Function_Call then |
6333ad3d | 2594 | Obj := First_Actual (Orig_Node); |
cad97339 | 2595 | |
1ca46a77 | 2596 | -- If neither, the name comes from source |
cad97339 AC |
2597 | |
2598 | else | |
2599 | Obj := Iter_Name; | |
7166d535 AC |
2600 | end if; |
2601 | ||
2602 | if Nkind (Obj) = N_Selected_Component | |
2603 | and then Is_Dependent_Component_Of_Mutable_Object (Obj) | |
2604 | then | |
2605 | Error_Msg_N | |
cc68dfe2 AC |
2606 | ("container cannot be a discriminant-dependent " |
2607 | & "component of a mutable object", N); | |
7166d535 AC |
2608 | end if; |
2609 | end; | |
2610 | end if; | |
2611 | ||
804670f1 AC |
2612 | -- The result type of Iterate function is the classwide type of |
2613 | -- the interface parent. We need the specific Cursor type defined | |
110e2969 AC |
2614 | -- in the container package. We obtain it by name for a predefined |
2615 | -- container, or through the Iterable aspect for a formal one. | |
804670f1 | 2616 | |
110e2969 AC |
2617 | if Has_Aspect (Typ, Aspect_Iterable) then |
2618 | Set_Etype (Def_Id, | |
2619 | Get_Cursor_Type | |
ebb6b0bd AC |
2620 | (Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)), |
2621 | Typ)); | |
804670f1 | 2622 | |
110e2969 | 2623 | else |
cad97339 | 2624 | Set_Etype (Def_Id, Get_Cursor_Type (Typ)); |
e361e9a1 | 2625 | Check_Reverse_Iteration (Etype (Iter_Name)); |
110e2969 | 2626 | end if; |
7166d535 | 2627 | |
bc49df98 | 2628 | end if; |
804670f1 AC |
2629 | end if; |
2630 | end Analyze_Iterator_Specification; | |
bc49df98 | 2631 | |
804670f1 AC |
2632 | ------------------- |
2633 | -- Analyze_Label -- | |
2634 | ------------------- | |
2635 | ||
2636 | -- Note: the semantic work required for analyzing labels (setting them as | |
2637 | -- reachable) was done in a prepass through the statements in the block, | |
2638 | -- so that forward gotos would be properly handled. See Analyze_Statements | |
2639 | -- for further details. The only processing required here is to deal with | |
2640 | -- optimizations that depend on an assumption of sequential control flow, | |
2641 | -- since of course the occurrence of a label breaks this assumption. | |
98123480 | 2642 | |
804670f1 AC |
2643 | procedure Analyze_Label (N : Node_Id) is |
2644 | pragma Warnings (Off, N); | |
2645 | begin | |
2646 | Kill_Current_Values; | |
2647 | end Analyze_Label; | |
ffe9aba8 | 2648 | |
804670f1 AC |
2649 | -------------------------- |
2650 | -- Analyze_Label_Entity -- | |
2651 | -------------------------- | |
ffe9aba8 | 2652 | |
804670f1 AC |
2653 | procedure Analyze_Label_Entity (E : Entity_Id) is |
2654 | begin | |
2655 | Set_Ekind (E, E_Label); | |
2656 | Set_Etype (E, Standard_Void_Type); | |
2657 | Set_Enclosing_Scope (E, Current_Scope); | |
2658 | Set_Reachable (E, True); | |
2659 | end Analyze_Label_Entity; | |
ffe9aba8 | 2660 | |
804670f1 AC |
2661 | ------------------------------------------ |
2662 | -- Analyze_Loop_Parameter_Specification -- | |
2663 | ------------------------------------------ | |
2664 | ||
2665 | procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is | |
2666 | Loop_Nod : constant Node_Id := Parent (Parent (N)); | |
2667 | ||
2668 | procedure Check_Controlled_Array_Attribute (DS : Node_Id); | |
2669 | -- If the bounds are given by a 'Range reference on a function call | |
2670 | -- that returns a controlled array, introduce an explicit declaration | |
2671 | -- to capture the bounds, so that the function result can be finalized | |
2672 | -- in timely fashion. | |
2673 | ||
24de083f AC |
2674 | procedure Check_Predicate_Use (T : Entity_Id); |
2675 | -- Diagnose Attempt to iterate through non-static predicate. Note that | |
2676 | -- a type with inherited predicates may have both static and dynamic | |
2677 | -- forms. In this case it is not sufficent to check the static predicate | |
2678 | -- function only, look for a dynamic predicate aspect as well. | |
2679 | ||
804670f1 AC |
2680 | procedure Process_Bounds (R : Node_Id); |
2681 | -- If the iteration is given by a range, create temporaries and | |
2682 | -- assignment statements block to capture the bounds and perform | |
2683 | -- required finalization actions in case a bound includes a function | |
812e6118 | 2684 | -- call that uses the temporary stack. We first preanalyze a copy of |
804670f1 AC |
2685 | -- the range in order to determine the expected type, and analyze and |
2686 | -- resolve the original bounds. | |
ffe9aba8 | 2687 | |
9596236a AC |
2688 | -------------------------------------- |
2689 | -- Check_Controlled_Array_Attribute -- | |
2690 | -------------------------------------- | |
2691 | ||
2692 | procedure Check_Controlled_Array_Attribute (DS : Node_Id) is | |
2693 | begin | |
2694 | if Nkind (DS) = N_Attribute_Reference | |
804670f1 AC |
2695 | and then Is_Entity_Name (Prefix (DS)) |
2696 | and then Ekind (Entity (Prefix (DS))) = E_Function | |
2697 | and then Is_Array_Type (Etype (Entity (Prefix (DS)))) | |
2698 | and then | |
2699 | Is_Controlled (Component_Type (Etype (Entity (Prefix (DS))))) | |
2700 | and then Expander_Active | |
9596236a AC |
2701 | then |
2702 | declare | |
2703 | Loc : constant Source_Ptr := Sloc (N); | |
092ef350 | 2704 | Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); |
9596236a AC |
2705 | Indx : constant Entity_Id := |
2706 | Base_Type (Etype (First_Index (Arr))); | |
092ef350 | 2707 | Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); |
9596236a AC |
2708 | Decl : Node_Id; |
2709 | ||
2710 | begin | |
2711 | Decl := | |
2712 | Make_Subtype_Declaration (Loc, | |
2713 | Defining_Identifier => Subt, | |
2714 | Subtype_Indication => | |
2715 | Make_Subtype_Indication (Loc, | |
e4494292 | 2716 | Subtype_Mark => New_Occurrence_Of (Indx, Loc), |
804670f1 AC |
2717 | Constraint => |
2718 | Make_Range_Constraint (Loc, Relocate_Node (DS)))); | |
2719 | Insert_Before (Loop_Nod, Decl); | |
9596236a AC |
2720 | Analyze (Decl); |
2721 | ||
2722 | Rewrite (DS, | |
804670f1 | 2723 | Make_Attribute_Reference (Loc, |
e4494292 | 2724 | Prefix => New_Occurrence_Of (Subt, Loc), |
804670f1 AC |
2725 | Attribute_Name => Attribute_Name (DS))); |
2726 | ||
9596236a AC |
2727 | Analyze (DS); |
2728 | end; | |
2729 | end if; | |
2730 | end Check_Controlled_Array_Attribute; | |
2731 | ||
24de083f AC |
2732 | ------------------------- |
2733 | -- Check_Predicate_Use -- | |
2734 | ------------------------- | |
2735 | ||
2736 | procedure Check_Predicate_Use (T : Entity_Id) is | |
2737 | begin | |
bb304287 | 2738 | -- A predicated subtype is illegal in loops and related constructs |
0fea901b AC |
2739 | -- if the predicate is not static, or if it is a non-static subtype |
2740 | -- of a statically predicated subtype. | |
bb304287 | 2741 | |
24de083f AC |
2742 | if Is_Discrete_Type (T) |
2743 | and then Has_Predicates (T) | |
2744 | and then (not Has_Static_Predicate (T) | |
bb304287 | 2745 | or else not Is_Static_Subtype (T) |
24de083f AC |
2746 | or else Has_Dynamic_Predicate_Aspect (T)) |
2747 | then | |
0fea901b AC |
2748 | -- Seems a confusing message for the case of a static predicate |
2749 | -- with a non-static subtype??? | |
2750 | ||
24de083f | 2751 | Bad_Predicated_Subtype_Use |
b330e3c8 AC |
2752 | ("cannot use subtype& with non-static predicate for loop " |
2753 | & "iteration", Discrete_Subtype_Definition (N), | |
2754 | T, Suggest_Static => True); | |
24de083f | 2755 | |
333e4f86 AC |
2756 | elsif Inside_A_Generic |
2757 | and then Is_Generic_Formal (T) | |
2758 | and then Is_Discrete_Type (T) | |
2759 | then | |
24de083f AC |
2760 | Set_No_Dynamic_Predicate_On_Actual (T); |
2761 | end if; | |
2762 | end Check_Predicate_Use; | |
2763 | ||
804670f1 AC |
2764 | -------------------- |
2765 | -- Process_Bounds -- | |
2766 | -------------------- | |
57a8057a | 2767 | |
804670f1 AC |
2768 | procedure Process_Bounds (R : Node_Id) is |
2769 | Loc : constant Source_Ptr := Sloc (N); | |
57a8057a | 2770 | |
804670f1 AC |
2771 | function One_Bound |
2772 | (Original_Bound : Node_Id; | |
2773 | Analyzed_Bound : Node_Id; | |
2774 | Typ : Entity_Id) return Node_Id; | |
2775 | -- Capture value of bound and return captured value | |
57a8057a | 2776 | |
804670f1 AC |
2777 | --------------- |
2778 | -- One_Bound -- | |
2779 | --------------- | |
b8789727 | 2780 | |
804670f1 AC |
2781 | function One_Bound |
2782 | (Original_Bound : Node_Id; | |
2783 | Analyzed_Bound : Node_Id; | |
2784 | Typ : Entity_Id) return Node_Id | |
2785 | is | |
2786 | Assign : Node_Id; | |
2787 | Decl : Node_Id; | |
2788 | Id : Entity_Id; | |
fb86fe11 | 2789 | |
804670f1 AC |
2790 | begin |
2791 | -- If the bound is a constant or an object, no need for a separate | |
2792 | -- declaration. If the bound is the result of previous expansion | |
2793 | -- it is already analyzed and should not be modified. Note that | |
2794 | -- the Bound will be resolved later, if needed, as part of the | |
2795 | -- call to Make_Index (literal bounds may need to be resolved to | |
2796 | -- type Integer). | |
fb86fe11 | 2797 | |
804670f1 AC |
2798 | if Analyzed (Original_Bound) then |
2799 | return Original_Bound; | |
996ae0b0 | 2800 | |
804670f1 AC |
2801 | elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, |
2802 | N_Character_Literal) | |
2803 | or else Is_Entity_Name (Analyzed_Bound) | |
2804 | then | |
2805 | Analyze_And_Resolve (Original_Bound, Typ); | |
2806 | return Original_Bound; | |
2807 | end if; | |
ffe9aba8 | 2808 | |
804670f1 AC |
2809 | -- Normally, the best approach is simply to generate a constant |
2810 | -- declaration that captures the bound. However, there is a nasty | |
2811 | -- case where this is wrong. If the bound is complex, and has a | |
2812 | -- possible use of the secondary stack, we need to generate a | |
2813 | -- separate assignment statement to ensure the creation of a block | |
2814 | -- which will release the secondary stack. | |
996ae0b0 | 2815 | |
804670f1 AC |
2816 | -- We prefer the constant declaration, since it leaves us with a |
2817 | -- proper trace of the value, useful in optimizations that get rid | |
2818 | -- of junk range checks. | |
c7532b2d | 2819 | |
abbfd698 | 2820 | if not Has_Sec_Stack_Call (Analyzed_Bound) then |
804670f1 | 2821 | Analyze_And_Resolve (Original_Bound, Typ); |
2838fa93 AC |
2822 | |
2823 | -- Ensure that the bound is valid. This check should not be | |
2824 | -- generated when the range belongs to a quantified expression | |
2825 | -- as the construct is still not expanded into its final form. | |
2826 | ||
2827 | if Nkind (Parent (R)) /= N_Loop_Parameter_Specification | |
2828 | or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression | |
2829 | then | |
2830 | Ensure_Valid (Original_Bound); | |
2831 | end if; | |
2832 | ||
804670f1 AC |
2833 | Force_Evaluation (Original_Bound); |
2834 | return Original_Bound; | |
2835 | end if; | |
c7532b2d | 2836 | |
804670f1 | 2837 | Id := Make_Temporary (Loc, 'R', Original_Bound); |
c7532b2d | 2838 | |
804670f1 AC |
2839 | -- Here we make a declaration with a separate assignment |
2840 | -- statement, and insert before loop header. | |
76efd572 | 2841 | |
804670f1 AC |
2842 | Decl := |
2843 | Make_Object_Declaration (Loc, | |
2844 | Defining_Identifier => Id, | |
2845 | Object_Definition => New_Occurrence_Of (Typ, Loc)); | |
c7532b2d | 2846 | |
804670f1 AC |
2847 | Assign := |
2848 | Make_Assignment_Statement (Loc, | |
2849 | Name => New_Occurrence_Of (Id, Loc), | |
2850 | Expression => Relocate_Node (Original_Bound)); | |
76efd572 | 2851 | |
804670f1 | 2852 | Insert_Actions (Loop_Nod, New_List (Decl, Assign)); |
996ae0b0 | 2853 | |
804670f1 AC |
2854 | -- Now that this temporary variable is initialized we decorate it |
2855 | -- as safe-to-reevaluate to inform to the backend that no further | |
2856 | -- asignment will be issued and hence it can be handled as side | |
2857 | -- effect free. Note that this decoration must be done when the | |
2858 | -- assignment has been analyzed because otherwise it will be | |
2859 | -- rejected (see Analyze_Assignment). | |
011f9d5d | 2860 | |
804670f1 | 2861 | Set_Is_Safe_To_Reevaluate (Id); |
996ae0b0 | 2862 | |
804670f1 | 2863 | Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); |
1f250383 | 2864 | |
804670f1 AC |
2865 | if Nkind (Assign) = N_Assignment_Statement then |
2866 | return Expression (Assign); | |
2867 | else | |
2868 | return Original_Bound; | |
2869 | end if; | |
2870 | end One_Bound; | |
1f250383 | 2871 | |
804670f1 AC |
2872 | Hi : constant Node_Id := High_Bound (R); |
2873 | Lo : constant Node_Id := Low_Bound (R); | |
2874 | R_Copy : constant Node_Id := New_Copy_Tree (R); | |
2875 | New_Hi : Node_Id; | |
2876 | New_Lo : Node_Id; | |
2877 | Typ : Entity_Id; | |
996ae0b0 | 2878 | |
804670f1 | 2879 | -- Start of processing for Process_Bounds |
996ae0b0 | 2880 | |
804670f1 AC |
2881 | begin |
2882 | Set_Parent (R_Copy, Parent (R)); | |
2883 | Preanalyze_Range (R_Copy); | |
2884 | Typ := Etype (R_Copy); | |
996ae0b0 | 2885 | |
804670f1 AC |
2886 | -- If the type of the discrete range is Universal_Integer, then the |
2887 | -- bound's type must be resolved to Integer, and any object used to | |
2888 | -- hold the bound must also have type Integer, unless the literal | |
2889 | -- bounds are constant-folded expressions with a user-defined type. | |
ed00f472 | 2890 | |
804670f1 AC |
2891 | if Typ = Universal_Integer then |
2892 | if Nkind (Lo) = N_Integer_Literal | |
2893 | and then Present (Etype (Lo)) | |
2894 | and then Scope (Etype (Lo)) /= Standard_Standard | |
2895 | then | |
2896 | Typ := Etype (Lo); | |
fbf5a39b | 2897 | |
804670f1 AC |
2898 | elsif Nkind (Hi) = N_Integer_Literal |
2899 | and then Present (Etype (Hi)) | |
2900 | and then Scope (Etype (Hi)) /= Standard_Standard | |
2901 | then | |
2902 | Typ := Etype (Hi); | |
fbf5a39b | 2903 | |
804670f1 AC |
2904 | else |
2905 | Typ := Standard_Integer; | |
2906 | end if; | |
2907 | end if; | |
996ae0b0 | 2908 | |
804670f1 | 2909 | Set_Etype (R, Typ); |
996ae0b0 | 2910 | |
804670f1 AC |
2911 | New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ); |
2912 | New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ); | |
fbf5a39b | 2913 | |
804670f1 AC |
2914 | -- Propagate staticness to loop range itself, in case the |
2915 | -- corresponding subtype is static. | |
fbf5a39b | 2916 | |
edab6088 | 2917 | if New_Lo /= Lo and then Is_OK_Static_Expression (New_Lo) then |
804670f1 AC |
2918 | Rewrite (Low_Bound (R), New_Copy (New_Lo)); |
2919 | end if; | |
fbf5a39b | 2920 | |
edab6088 | 2921 | if New_Hi /= Hi and then Is_OK_Static_Expression (New_Hi) then |
804670f1 | 2922 | Rewrite (High_Bound (R), New_Copy (New_Hi)); |
ed00f472 | 2923 | end if; |
804670f1 | 2924 | end Process_Bounds; |
996ae0b0 | 2925 | |
804670f1 | 2926 | -- Local variables |
57d62f0c | 2927 | |
804670f1 AC |
2928 | DS : constant Node_Id := Discrete_Subtype_Definition (N); |
2929 | Id : constant Entity_Id := Defining_Identifier (N); | |
57d62f0c | 2930 | |
804670f1 AC |
2931 | DS_Copy : Node_Id; |
2932 | ||
2933 | -- Start of processing for Analyze_Loop_Parameter_Specification | |
57d62f0c AC |
2934 | |
2935 | begin | |
804670f1 | 2936 | Enter_Name (Id); |
36b8f95f | 2937 | |
804670f1 AC |
2938 | -- We always consider the loop variable to be referenced, since the loop |
2939 | -- may be used just for counting purposes. | |
57d62f0c | 2940 | |
804670f1 | 2941 | Generate_Reference (Id, N, ' '); |
57d62f0c | 2942 | |
804670f1 AC |
2943 | -- Check for the case of loop variable hiding a local variable (used |
2944 | -- later on to give a nice warning if the hidden variable is never | |
2945 | -- assigned). | |
62db841a | 2946 | |
804670f1 AC |
2947 | declare |
2948 | H : constant Entity_Id := Homonym (Id); | |
2949 | begin | |
2950 | if Present (H) | |
2951 | and then Ekind (H) = E_Variable | |
2952 | and then Is_Discrete_Type (Etype (H)) | |
2953 | and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id) | |
2954 | then | |
2955 | Set_Hiding_Loop_Variable (H, Id); | |
2956 | end if; | |
2957 | end; | |
fb86fe11 | 2958 | |
804670f1 AC |
2959 | -- Analyze the subtype definition and create temporaries for the bounds. |
2960 | -- Do not evaluate the range when preanalyzing a quantified expression | |
2961 | -- because bounds expressed as function calls with side effects will be | |
77a40ec1 | 2962 | -- incorrectly replicated. |
57a8057a | 2963 | |
804670f1 AC |
2964 | if Nkind (DS) = N_Range |
2965 | and then Expander_Active | |
2966 | and then Nkind (Parent (N)) /= N_Quantified_Expression | |
2967 | then | |
2968 | Process_Bounds (DS); | |
fb86fe11 | 2969 | |
804670f1 AC |
2970 | -- Either the expander not active or the range of iteration is a subtype |
2971 | -- indication, an entity, or a function call that yields an aggregate or | |
2972 | -- a container. | |
57a8057a | 2973 | |
804670f1 AC |
2974 | else |
2975 | DS_Copy := New_Copy_Tree (DS); | |
2976 | Set_Parent (DS_Copy, Parent (DS)); | |
2977 | Preanalyze_Range (DS_Copy); | |
2978 | ||
28108618 ES |
2979 | -- Ada 2012: If the domain of iteration is: |
2980 | ||
2981 | -- a) a function call, | |
2982 | -- b) an identifier that is not a type, | |
ad81cb78 AC |
2983 | -- c) an attribute reference 'Old (within a postcondition), |
2984 | -- d) an unchecked conversion or a qualified expression with | |
2985 | -- the proper iterator type. | |
28108618 ES |
2986 | |
2987 | -- then it is an iteration over a container. It was classified as | |
2988 | -- a loop specification by the parser, and must be rewritten now | |
511c5197 AC |
2989 | -- to activate container iteration. The last case will occur within |
2990 | -- an expanded inlined call, where the expansion wraps an actual in | |
2991 | -- an unchecked conversion when needed. The expression of the | |
2992 | -- conversion is always an object. | |
804670f1 | 2993 | |
804670f1 | 2994 | if Nkind (DS_Copy) = N_Function_Call |
ad81cb78 | 2995 | |
ac7d724d ES |
2996 | or else (Is_Entity_Name (DS_Copy) |
2997 | and then not Is_Type (Entity (DS_Copy))) | |
ad81cb78 | 2998 | |
28108618 | 2999 | or else (Nkind (DS_Copy) = N_Attribute_Reference |
12c5f1ef | 3000 | and then Nam_In (Attribute_Name (DS_Copy), |
ad81cb78 AC |
3001 | Name_Loop_Entry, Name_Old)) |
3002 | ||
12c5f1ef | 3003 | or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable) |
ad81cb78 AC |
3004 | |
3005 | or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion | |
3006 | or else (Nkind (DS_Copy) = N_Qualified_Expression | |
3007 | and then Is_Iterator (Etype (DS_Copy))) | |
804670f1 AC |
3008 | then |
3009 | -- This is an iterator specification. Rewrite it as such and | |
3010 | -- analyze it to capture function calls that may require | |
3011 | -- finalization actions. | |
833eaa8a | 3012 | |
57a8057a | 3013 | declare |
804670f1 AC |
3014 | I_Spec : constant Node_Id := |
3015 | Make_Iterator_Specification (Sloc (N), | |
3016 | Defining_Identifier => Relocate_Node (Id), | |
3017 | Name => DS_Copy, | |
3018 | Subtype_Indication => Empty, | |
3019 | Reverse_Present => Reverse_Present (N)); | |
3020 | Scheme : constant Node_Id := Parent (N); | |
57a8057a AC |
3021 | |
3022 | begin | |
804670f1 AC |
3023 | Set_Iterator_Specification (Scheme, I_Spec); |
3024 | Set_Loop_Parameter_Specification (Scheme, Empty); | |
3025 | Analyze_Iterator_Specification (I_Spec); | |
57a8057a | 3026 | |
804670f1 AC |
3027 | -- In a generic context, analyze the original domain of |
3028 | -- iteration, for name capture. | |
fb86fe11 | 3029 | |
804670f1 AC |
3030 | if not Expander_Active then |
3031 | Analyze (DS); | |
57a8057a | 3032 | end if; |
804670f1 AC |
3033 | |
3034 | -- Set kind of loop parameter, which may be used in the | |
3035 | -- subsequent analysis of the condition in a quantified | |
3036 | -- expression. | |
3037 | ||
3038 | Set_Ekind (Id, E_Loop_Parameter); | |
3039 | return; | |
57a8057a AC |
3040 | end; |
3041 | ||
804670f1 AC |
3042 | -- Domain of iteration is not a function call, and is side-effect |
3043 | -- free. | |
57a8057a | 3044 | |
833eaa8a | 3045 | else |
5277d0b7 | 3046 | -- A quantified expression that appears in a pre/post condition |
64ac53f4 | 3047 | -- is preanalyzed several times. If the range is given by an |
5277d0b7 AC |
3048 | -- attribute reference it is rewritten as a range, and this is |
3049 | -- done even with expansion disabled. If the type is already set | |
3050 | -- do not reanalyze, because a range with static bounds may be | |
3051 | -- typed Integer by default. | |
3052 | ||
3053 | if Nkind (Parent (N)) = N_Quantified_Expression | |
3054 | and then Present (Etype (DS)) | |
3055 | then | |
3056 | null; | |
3057 | else | |
3058 | Analyze (DS); | |
3059 | end if; | |
57a8057a | 3060 | end if; |
fb86fe11 ES |
3061 | end if; |
3062 | ||
804670f1 AC |
3063 | if DS = Error then |
3064 | return; | |
3065 | end if; | |
57d62f0c | 3066 | |
804670f1 | 3067 | -- Some additional checks if we are iterating through a type |
9ec080cb | 3068 | |
804670f1 AC |
3069 | if Is_Entity_Name (DS) |
3070 | and then Present (Entity (DS)) | |
3071 | and then Is_Type (Entity (DS)) | |
3072 | then | |
3073 | -- The subtype indication may denote the completion of an incomplete | |
3074 | -- type declaration. | |
20428725 | 3075 | |
804670f1 AC |
3076 | if Ekind (Entity (DS)) = E_Incomplete_Type then |
3077 | Set_Entity (DS, Get_Full_View (Entity (DS))); | |
3078 | Set_Etype (DS, Entity (DS)); | |
3079 | end if; | |
9ec080cb | 3080 | |
24de083f | 3081 | Check_Predicate_Use (Entity (DS)); |
804670f1 | 3082 | end if; |
36b8f95f | 3083 | |
804670f1 | 3084 | -- Error if not discrete type |
36b8f95f | 3085 | |
804670f1 AC |
3086 | if not Is_Discrete_Type (Etype (DS)) then |
3087 | Wrong_Type (DS, Any_Discrete); | |
3088 | Set_Etype (DS, Any_Type); | |
3089 | end if; | |
57d62f0c | 3090 | |
804670f1 AC |
3091 | Check_Controlled_Array_Attribute (DS); |
3092 | ||
24de083f AC |
3093 | if Nkind (DS) = N_Subtype_Indication then |
3094 | Check_Predicate_Use (Entity (Subtype_Mark (DS))); | |
3095 | end if; | |
3096 | ||
7907619e | 3097 | Make_Index (DS, N); |
804670f1 AC |
3098 | Set_Ekind (Id, E_Loop_Parameter); |
3099 | ||
3100 | -- A quantified expression which appears in a pre- or post-condition may | |
3101 | -- be analyzed multiple times. The analysis of the range creates several | |
3102 | -- itypes which reside in different scopes depending on whether the pre- | |
3103 | -- or post-condition has been expanded. Update the type of the loop | |
3104 | -- variable to reflect the proper itype at each stage of analysis. | |
3105 | ||
3106 | if No (Etype (Id)) | |
3107 | or else Etype (Id) = Any_Type | |
3108 | or else | |
3109 | (Present (Etype (Id)) | |
4c51ff88 AC |
3110 | and then Is_Itype (Etype (Id)) |
3111 | and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions | |
3112 | and then Nkind (Original_Node (Parent (Loop_Nod))) = | |
ac7d724d | 3113 | N_Quantified_Expression) |
804670f1 AC |
3114 | then |
3115 | Set_Etype (Id, Etype (DS)); | |
3116 | end if; | |
57a8057a | 3117 | |
804670f1 AC |
3118 | -- Treat a range as an implicit reference to the type, to inhibit |
3119 | -- spurious warnings. | |
57a8057a | 3120 | |
804670f1 AC |
3121 | Generate_Reference (Base_Type (Etype (DS)), N, ' '); |
3122 | Set_Is_Known_Valid (Id, True); | |
57d62f0c | 3123 | |
d99ff0f4 AC |
3124 | -- The loop is not a declarative part, so the loop variable must be |
3125 | -- frozen explicitly. Do not freeze while preanalyzing a quantified | |
3126 | -- expression because the freeze node will not be inserted into the | |
3127 | -- tree due to flag Is_Spec_Expression being set. | |
00c7151c | 3128 | |
d99ff0f4 AC |
3129 | if Nkind (Parent (N)) /= N_Quantified_Expression then |
3130 | declare | |
3131 | Flist : constant List_Id := Freeze_Entity (Id, N); | |
3132 | begin | |
3133 | if Is_Non_Empty_List (Flist) then | |
3134 | Insert_Actions (N, Flist); | |
3135 | end if; | |
3136 | end; | |
3137 | end if; | |
57d62f0c | 3138 | |
4c51ff88 | 3139 | -- Case where we have a range or a subtype, get type bounds |
57a8057a | 3140 | |
4c51ff88 AC |
3141 | if Nkind_In (DS, N_Range, N_Subtype_Indication) |
3142 | and then not Error_Posted (DS) | |
3143 | and then Etype (DS) /= Any_Type | |
3144 | and then Is_Discrete_Type (Etype (DS)) | |
3145 | then | |
804670f1 | 3146 | declare |
e4ef65f9 AC |
3147 | L : Node_Id; |
3148 | H : Node_Id; | |
3149 | Null_Range : Boolean := False; | |
57d62f0c | 3150 | |
804670f1 | 3151 | begin |
4c51ff88 AC |
3152 | if Nkind (DS) = N_Range then |
3153 | L := Low_Bound (DS); | |
3154 | H := High_Bound (DS); | |
3155 | else | |
3156 | L := | |
3157 | Type_Low_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); | |
3158 | H := | |
3159 | Type_High_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); | |
3160 | end if; | |
3161 | ||
3162 | -- Check for null or possibly null range and issue warning. We | |
3163 | -- suppress such messages in generic templates and instances, | |
3164 | -- because in practice they tend to be dubious in these cases. The | |
3165 | -- check applies as well to rewritten array element loops where a | |
3166 | -- null range may be detected statically. | |
08f8a983 | 3167 | |
804670f1 | 3168 | if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then |
e4ef65f9 AC |
3169 | if Compile_Time_Compare (L, H, Assume_Valid => False) = GT then |
3170 | -- Since we know the range of the loop is always null, | |
3171 | -- set the appropriate flag to remove the loop entirely | |
3172 | -- during expansion. | |
3173 | ||
3174 | Set_Is_Null_Loop (Loop_Nod); | |
3175 | Null_Range := True; | |
3176 | end if; | |
08f8a983 | 3177 | |
804670f1 AC |
3178 | -- Suppress the warning if inside a generic template or |
3179 | -- instance, since in practice they tend to be dubious in these | |
97027f64 | 3180 | -- cases since they can result from intended parameterization. |
08f8a983 | 3181 | |
ac7d724d ES |
3182 | if not Inside_A_Generic and then not In_Instance then |
3183 | ||
804670f1 AC |
3184 | -- Specialize msg if invalid values could make the loop |
3185 | -- non-null after all. | |
57d62f0c | 3186 | |
e4ef65f9 | 3187 | if Null_Range then |
979b94ea AC |
3188 | if Comes_From_Source (N) then |
3189 | Error_Msg_N | |
3190 | ("??loop range is null, loop will not execute", DS); | |
3191 | end if; | |
804670f1 | 3192 | |
e4ef65f9 AC |
3193 | -- Here is where the loop could execute because of |
3194 | -- invalid values, so issue appropriate message. | |
979b94ea AC |
3195 | |
3196 | elsif Comes_From_Source (N) then | |
804670f1 | 3197 | Error_Msg_N |
324ac540 AC |
3198 | ("??loop range may be null, loop may not execute", |
3199 | DS); | |
804670f1 | 3200 | Error_Msg_N |
324ac540 AC |
3201 | ("??can only execute if invalid values are present", |
3202 | DS); | |
804670f1 | 3203 | end if; |
57d62f0c AC |
3204 | end if; |
3205 | ||
804670f1 AC |
3206 | -- In either case, suppress warnings in the body of the loop, |
3207 | -- since it is likely that these warnings will be inappropriate | |
3208 | -- if the loop never actually executes, which is likely. | |
57d62f0c | 3209 | |
804670f1 | 3210 | Set_Suppress_Loop_Warnings (Loop_Nod); |
996ae0b0 | 3211 | |
804670f1 AC |
3212 | -- The other case for a warning is a reverse loop where the |
3213 | -- upper bound is the integer literal zero or one, and the | |
ac7d724d | 3214 | -- lower bound may exceed this value. |
996ae0b0 | 3215 | |
804670f1 | 3216 | -- For example, we have |
996ae0b0 | 3217 | |
804670f1 | 3218 | -- for J in reverse N .. 1 loop |
996ae0b0 | 3219 | |
804670f1 AC |
3220 | -- In practice, this is very likely to be a case of reversing |
3221 | -- the bounds incorrectly in the range. | |
3222 | ||
3223 | elsif Reverse_Present (N) | |
3224 | and then Nkind (Original_Node (H)) = N_Integer_Literal | |
3225 | and then | |
3226 | (Intval (Original_Node (H)) = Uint_0 | |
ac7d724d ES |
3227 | or else |
3228 | Intval (Original_Node (H)) = Uint_1) | |
804670f1 | 3229 | then |
ac7d724d ES |
3230 | -- Lower bound may in fact be known and known not to exceed |
3231 | -- upper bound (e.g. reverse 0 .. 1) and that's OK. | |
3232 | ||
3233 | if Compile_Time_Known_Value (L) | |
3234 | and then Expr_Value (L) <= Expr_Value (H) | |
3235 | then | |
3236 | null; | |
3237 | ||
3238 | -- Otherwise warning is warranted | |
3239 | ||
3240 | else | |
3241 | Error_Msg_N ("??loop range may be null", DS); | |
3242 | Error_Msg_N ("\??bounds may be wrong way round", DS); | |
3243 | end if; | |
804670f1 | 3244 | end if; |
4c51ff88 AC |
3245 | |
3246 | -- Check if either bound is known to be outside the range of the | |
3247 | -- loop parameter type, this is e.g. the case of a loop from | |
3248 | -- 20..X where the type is 1..19. | |
3249 | ||
3250 | -- Such a loop is dubious since either it raises CE or it executes | |
3251 | -- zero times, and that cannot be useful! | |
3252 | ||
3253 | if Etype (DS) /= Any_Type | |
3254 | and then not Error_Posted (DS) | |
3255 | and then Nkind (DS) = N_Subtype_Indication | |
3256 | and then Nkind (Constraint (DS)) = N_Range_Constraint | |
3257 | then | |
3258 | declare | |
3259 | LLo : constant Node_Id := | |
3260 | Low_Bound (Range_Expression (Constraint (DS))); | |
3261 | LHi : constant Node_Id := | |
3262 | High_Bound (Range_Expression (Constraint (DS))); | |
3263 | ||
3264 | Bad_Bound : Node_Id := Empty; | |
3265 | -- Suspicious loop bound | |
3266 | ||
3267 | begin | |
3268 | -- At this stage L, H are the bounds of the type, and LLo | |
3269 | -- Lhi are the low bound and high bound of the loop. | |
3270 | ||
3271 | if Compile_Time_Compare (LLo, L, Assume_Valid => True) = LT | |
3272 | or else | |
3273 | Compile_Time_Compare (LLo, H, Assume_Valid => True) = GT | |
3274 | then | |
3275 | Bad_Bound := LLo; | |
3276 | end if; | |
3277 | ||
3278 | if Compile_Time_Compare (LHi, L, Assume_Valid => True) = LT | |
3279 | or else | |
3280 | Compile_Time_Compare (LHi, H, Assume_Valid => True) = GT | |
3281 | then | |
3282 | Bad_Bound := LHi; | |
3283 | end if; | |
3284 | ||
3285 | if Present (Bad_Bound) then | |
3286 | Error_Msg_N | |
3287 | ("suspicious loop bound out of range of " | |
3288 | & "loop subtype??", Bad_Bound); | |
3289 | Error_Msg_N | |
3290 | ("\loop executes zero times or raises " | |
3291 | & "Constraint_Error??", Bad_Bound); | |
3292 | end if; | |
3293 | end; | |
3294 | end if; | |
3295 | ||
3296 | -- This declare block is about warnings, if we get an exception while | |
3297 | -- testing for warnings, we simply abandon the attempt silently. This | |
3298 | -- most likely occurs as the result of a previous error, but might | |
3299 | -- just be an obscure case we have missed. In either case, not giving | |
3300 | -- the warning is perfectly acceptable. | |
3301 | ||
3302 | exception | |
3303 | when others => null; | |
804670f1 AC |
3304 | end; |
3305 | end if; | |
f1bd0415 | 3306 | |
847d950d HK |
3307 | -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)). |
3308 | -- This check is relevant only when SPARK_Mode is on as it is not a | |
3309 | -- standard Ada legality check. | |
f1bd0415 | 3310 | |
d780e54f | 3311 | if SPARK_Mode = On and then Is_Effectively_Volatile (Id) then |
f9966234 | 3312 | Error_Msg_N ("loop parameter cannot be volatile", Id); |
f1bd0415 | 3313 | end if; |
804670f1 | 3314 | end Analyze_Loop_Parameter_Specification; |
996ae0b0 RK |
3315 | |
3316 | ---------------------------- | |
3317 | -- Analyze_Loop_Statement -- | |
3318 | ---------------------------- | |
3319 | ||
3320 | procedure Analyze_Loop_Statement (N : Node_Id) is | |
27c489df | 3321 | |
abbfd698 HK |
3322 | -- The following exception is raised by routine Prepare_Loop_Statement |
3323 | -- to avoid further analysis of a transformed loop. | |
3324 | ||
ace11c95 AC |
3325 | procedure Prepare_Loop_Statement |
3326 | (Iter : Node_Id; | |
3327 | Stop_Processing : out Boolean); | |
abbfd698 | 3328 | -- Determine whether loop statement N with iteration scheme Iter must be |
ace11c95 AC |
3329 | -- transformed prior to analysis, and if so, perform it. |
3330 | -- If Stop_Processing is set to True, should stop further processing. | |
ef992452 | 3331 | |
abbfd698 HK |
3332 | ---------------------------- |
3333 | -- Prepare_Loop_Statement -- | |
3334 | ---------------------------- | |
3335 | ||
ace11c95 AC |
3336 | procedure Prepare_Loop_Statement |
3337 | (Iter : Node_Id; | |
3338 | Stop_Processing : out Boolean) | |
3339 | is | |
abbfd698 HK |
3340 | function Has_Sec_Stack_Default_Iterator |
3341 | (Cont_Typ : Entity_Id) return Boolean; | |
3342 | pragma Inline (Has_Sec_Stack_Default_Iterator); | |
3343 | -- Determine whether container type Cont_Typ has a default iterator | |
3344 | -- that requires secondary stack management. | |
3345 | ||
3346 | function Is_Sec_Stack_Iteration_Primitive | |
3347 | (Cont_Typ : Entity_Id; | |
3348 | Iter_Prim_Nam : Name_Id) return Boolean; | |
3349 | pragma Inline (Is_Sec_Stack_Iteration_Primitive); | |
3350 | -- Determine whether container type Cont_Typ has an iteration routine | |
3351 | -- described by its name Iter_Prim_Nam that requires secondary stack | |
3352 | -- management. | |
3353 | ||
3354 | function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean; | |
3355 | pragma Inline (Is_Wrapped_In_Block); | |
3356 | -- Determine whether arbitrary statement Stmt is the sole statement | |
3357 | -- wrapped within some block, excluding pragmas. | |
3358 | ||
ace11c95 AC |
3359 | procedure Prepare_Iterator_Loop |
3360 | (Iter_Spec : Node_Id; | |
3361 | Stop_Processing : out Boolean); | |
abbfd698 HK |
3362 | pragma Inline (Prepare_Iterator_Loop); |
3363 | -- Prepare an iterator loop with iteration specification Iter_Spec | |
3364 | -- for transformation if needed. | |
ace11c95 | 3365 | -- If Stop_Processing is set to True, should stop further processing. |
abbfd698 | 3366 | |
ace11c95 AC |
3367 | procedure Prepare_Param_Spec_Loop |
3368 | (Param_Spec : Node_Id; | |
3369 | Stop_Processing : out Boolean); | |
abbfd698 HK |
3370 | pragma Inline (Prepare_Param_Spec_Loop); |
3371 | -- Prepare a discrete loop with parameter specification Param_Spec | |
3372 | -- for transformation if needed. | |
ace11c95 | 3373 | -- If Stop_Processing is set to True, should stop further processing. |
abbfd698 HK |
3374 | |
3375 | procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean); | |
ace11c95 | 3376 | pragma Inline (Wrap_Loop_Statement); |
abbfd698 HK |
3377 | -- Wrap loop statement N within a block. Flag Manage_Sec_Stack must |
3378 | -- be set when the block must mark and release the secondary stack. | |
ace11c95 | 3379 | -- Should stop further processing after calling this procedure. |
abbfd698 HK |
3380 | |
3381 | ------------------------------------ | |
3382 | -- Has_Sec_Stack_Default_Iterator -- | |
3383 | ------------------------------------ | |
3384 | ||
3385 | function Has_Sec_Stack_Default_Iterator | |
3386 | (Cont_Typ : Entity_Id) return Boolean | |
3387 | is | |
3388 | Def_Iter : constant Node_Id := | |
3389 | Find_Value_Of_Aspect | |
3390 | (Cont_Typ, Aspect_Default_Iterator); | |
3391 | begin | |
3392 | return | |
3393 | Present (Def_Iter) | |
3394 | and then Requires_Transient_Scope (Etype (Def_Iter)); | |
3395 | end Has_Sec_Stack_Default_Iterator; | |
3396 | ||
3397 | -------------------------------------- | |
3398 | -- Is_Sec_Stack_Iteration_Primitive -- | |
3399 | -------------------------------------- | |
3400 | ||
3401 | function Is_Sec_Stack_Iteration_Primitive | |
3402 | (Cont_Typ : Entity_Id; | |
3403 | Iter_Prim_Nam : Name_Id) return Boolean | |
3404 | is | |
3405 | Iter_Prim : constant Entity_Id := | |
3406 | Get_Iterable_Type_Primitive | |
3407 | (Cont_Typ, Iter_Prim_Nam); | |
3408 | begin | |
3409 | return | |
3410 | Present (Iter_Prim) | |
3411 | and then Requires_Transient_Scope (Etype (Iter_Prim)); | |
3412 | end Is_Sec_Stack_Iteration_Primitive; | |
95f2be29 | 3413 | |
abbfd698 HK |
3414 | ------------------------- |
3415 | -- Is_Wrapped_In_Block -- | |
3416 | ------------------------- | |
ef992452 | 3417 | |
abbfd698 HK |
3418 | function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean is |
3419 | Blk_HSS : Node_Id; | |
3420 | Blk_Id : Entity_Id; | |
3421 | Blk_Stmt : Node_Id; | |
ef992452 | 3422 | |
abbfd698 HK |
3423 | begin |
3424 | Blk_Id := Current_Scope; | |
ef992452 | 3425 | |
abbfd698 HK |
3426 | -- The current context is a block. Inspect the statements of the |
3427 | -- block to determine whether it wraps Stmt. | |
3428 | ||
3429 | if Ekind (Blk_Id) = E_Block | |
3430 | and then Present (Block_Node (Blk_Id)) | |
3431 | then | |
3432 | Blk_HSS := | |
3433 | Handled_Statement_Sequence (Parent (Block_Node (Blk_Id))); | |
3434 | ||
3435 | -- Skip leading pragmas introduced for invariant and predicate | |
3436 | -- checks. | |
3437 | ||
3438 | Blk_Stmt := First (Statements (Blk_HSS)); | |
3439 | while Present (Blk_Stmt) | |
3440 | and then Nkind (Blk_Stmt) = N_Pragma | |
3441 | loop | |
3442 | Next (Blk_Stmt); | |
3443 | end loop; | |
3444 | ||
3445 | return Blk_Stmt = Stmt and then No (Next (Blk_Stmt)); | |
3446 | end if; | |
ef992452 | 3447 | |
ef992452 | 3448 | return False; |
abbfd698 | 3449 | end Is_Wrapped_In_Block; |
ef992452 | 3450 | |
abbfd698 HK |
3451 | --------------------------- |
3452 | -- Prepare_Iterator_Loop -- | |
3453 | --------------------------- | |
ef992452 | 3454 | |
ace11c95 AC |
3455 | procedure Prepare_Iterator_Loop |
3456 | (Iter_Spec : Node_Id; | |
3457 | Stop_Processing : out Boolean) | |
3458 | is | |
abbfd698 HK |
3459 | Cont_Typ : Entity_Id; |
3460 | Nam : Node_Id; | |
3461 | Nam_Copy : Node_Id; | |
ef992452 | 3462 | |
abbfd698 | 3463 | begin |
ace11c95 AC |
3464 | Stop_Processing := False; |
3465 | ||
abbfd698 HK |
3466 | -- The iterator specification has syntactic errors. Transform the |
3467 | -- loop into an infinite loop in order to safely perform at least | |
3468 | -- some minor analysis. This check must come first. | |
3469 | ||
3470 | if Error_Posted (Iter_Spec) then | |
3471 | Set_Iteration_Scheme (N, Empty); | |
3472 | Analyze (N); | |
ace11c95 | 3473 | Stop_Processing := True; |
abbfd698 HK |
3474 | |
3475 | -- Nothing to do when the loop is already wrapped in a block | |
3476 | ||
3477 | elsif Is_Wrapped_In_Block (N) then | |
3478 | null; | |
3479 | ||
3480 | -- Otherwise the iterator loop traverses an array or a container | |
3481 | -- and appears in the form | |
3482 | -- | |
3483 | -- for Def_Id in [reverse] Iterator_Name loop | |
3484 | -- for Def_Id [: Subtyp_Indic] of [reverse] Iterable_Name loop | |
3485 | ||
3486 | else | |
3487 | -- Prepare a copy of the iterated name for preanalysis. The | |
3488 | -- copy is semi inserted into the tree by setting its Parent | |
3489 | -- pointer. | |
3490 | ||
3491 | Nam := Name (Iter_Spec); | |
ef992452 AC |
3492 | Nam_Copy := New_Copy_Tree (Nam); |
3493 | Set_Parent (Nam_Copy, Parent (Nam)); | |
abbfd698 HK |
3494 | |
3495 | -- Determine what the loop is iterating on | |
3496 | ||
804670f1 | 3497 | Preanalyze_Range (Nam_Copy); |
abbfd698 | 3498 | Cont_Typ := Etype (Nam_Copy); |
ef992452 | 3499 | |
abbfd698 HK |
3500 | -- The iterator loop is traversing an array. This case does not |
3501 | -- require any transformation. | |
ef992452 | 3502 | |
abbfd698 HK |
3503 | if Is_Array_Type (Cont_Typ) then |
3504 | null; | |
ef992452 | 3505 | |
abbfd698 HK |
3506 | -- Otherwise unconditionally wrap the loop statement within |
3507 | -- a block. The expansion of iterator loops may relocate the | |
3508 | -- iterator outside the loop, thus "leaking" its entity into | |
3509 | -- the enclosing scope. Wrapping the loop statement allows | |
3510 | -- for multiple iterator loops using the same iterator name | |
3511 | -- to coexist within the same scope. | |
3512 | -- | |
3513 | -- The block must manage the secondary stack when the iterator | |
3514 | -- loop is traversing a container using either | |
3515 | -- | |
3516 | -- * A default iterator obtained on the secondary stack | |
3517 | -- | |
3518 | -- * Call to Iterate where the iterator is returned on the | |
3519 | -- secondary stack. | |
3520 | -- | |
3521 | -- * Combination of First, Next, and Has_Element where the | |
3522 | -- first two return a cursor on the secondary stack. | |
ef992452 | 3523 | |
abbfd698 HK |
3524 | else |
3525 | Wrap_Loop_Statement | |
3526 | (Manage_Sec_Stack => | |
3527 | Has_Sec_Stack_Default_Iterator (Cont_Typ) | |
3528 | or else Has_Sec_Stack_Call (Nam_Copy) | |
3529 | or else Is_Sec_Stack_Iteration_Primitive | |
3530 | (Cont_Typ, Name_First) | |
3531 | or else Is_Sec_Stack_Iteration_Primitive | |
3532 | (Cont_Typ, Name_Next)); | |
ace11c95 | 3533 | Stop_Processing := True; |
abbfd698 HK |
3534 | end if; |
3535 | end if; | |
3536 | end Prepare_Iterator_Loop; | |
ef992452 | 3537 | |
abbfd698 HK |
3538 | ----------------------------- |
3539 | -- Prepare_Param_Spec_Loop -- | |
3540 | ----------------------------- | |
ef992452 | 3541 | |
ace11c95 AC |
3542 | procedure Prepare_Param_Spec_Loop |
3543 | (Param_Spec : Node_Id; | |
3544 | Stop_Processing : out Boolean) | |
3545 | is | |
abbfd698 HK |
3546 | High : Node_Id; |
3547 | Low : Node_Id; | |
3548 | Rng : Node_Id; | |
3549 | Rng_Copy : Node_Id; | |
3550 | Rng_Typ : Entity_Id; | |
ef992452 | 3551 | |
abbfd698 | 3552 | begin |
ace11c95 | 3553 | Stop_Processing := False; |
abbfd698 | 3554 | Rng := Discrete_Subtype_Definition (Param_Spec); |
ef992452 | 3555 | |
abbfd698 | 3556 | -- Nothing to do when the loop is already wrapped in a block |
ef992452 | 3557 | |
abbfd698 HK |
3558 | if Is_Wrapped_In_Block (N) then |
3559 | null; | |
ef992452 | 3560 | |
abbfd698 HK |
3561 | -- The parameter specification appears in the form |
3562 | -- | |
3563 | -- for Def_Id in Subtype_Mark Constraint loop | |
8f819471 | 3564 | |
abbfd698 HK |
3565 | elsif Nkind (Rng) = N_Subtype_Indication |
3566 | and then Nkind (Range_Expression (Constraint (Rng))) = N_Range | |
3567 | then | |
3568 | Rng := Range_Expression (Constraint (Rng)); | |
8f819471 | 3569 | |
ecb2f4fe GD |
3570 | -- Preanalyze the bounds of the range constraint, setting |
3571 | -- parent fields to associate the copied bounds with the range, | |
3572 | -- allowing proper tree climbing during preanalysis. | |
d6cd5d34 | 3573 | |
abbfd698 HK |
3574 | Low := New_Copy_Tree (Low_Bound (Rng)); |
3575 | High := New_Copy_Tree (High_Bound (Rng)); | |
d6cd5d34 | 3576 | |
ecb2f4fe GD |
3577 | Set_Parent (Low, Rng); |
3578 | Set_Parent (High, Rng); | |
3579 | ||
abbfd698 HK |
3580 | Preanalyze (Low); |
3581 | Preanalyze (High); | |
d6cd5d34 | 3582 | |
abbfd698 HK |
3583 | -- The bounds contain at least one function call that returns |
3584 | -- on the secondary stack. Note that the loop must be wrapped | |
3585 | -- only when such a call exists. | |
3586 | ||
ace11c95 | 3587 | if Has_Sec_Stack_Call (Low) or else Has_Sec_Stack_Call (High) |
abbfd698 HK |
3588 | then |
3589 | Wrap_Loop_Statement (Manage_Sec_Stack => True); | |
ace11c95 | 3590 | Stop_Processing := True; |
abbfd698 HK |
3591 | end if; |
3592 | ||
3593 | -- Otherwise the parameter specification appears in the form | |
3594 | -- | |
3595 | -- for Def_Id in Range loop | |
3596 | ||
3597 | else | |
3598 | -- Prepare a copy of the discrete range for preanalysis. The | |
3599 | -- copy is semi inserted into the tree by setting its Parent | |
3600 | -- pointer. | |
3601 | ||
3602 | Rng_Copy := New_Copy_Tree (Rng); | |
3603 | Set_Parent (Rng_Copy, Parent (Rng)); | |
3604 | ||
3605 | -- Determine what the loop is iterating on | |
3606 | ||
3607 | Preanalyze_Range (Rng_Copy); | |
3608 | Rng_Typ := Etype (Rng_Copy); | |
3609 | ||
3610 | -- Wrap the loop statement within a block in order to manage | |
3611 | -- the secondary stack when the discrete range is | |
3612 | -- | |
3613 | -- * Either a Forward_Iterator or a Reverse_Iterator | |
3614 | -- | |
3615 | -- * Function call whose return type requires finalization | |
3616 | -- actions. | |
3617 | ||
3618 | -- ??? it is unclear why using Has_Sec_Stack_Call directly on | |
3619 | -- the discrete range causes the freeze node of an itype to be | |
3620 | -- in the wrong scope in complex assertion expressions. | |
3621 | ||
3622 | if Is_Iterator (Rng_Typ) | |
3623 | or else (Nkind (Rng_Copy) = N_Function_Call | |
3624 | and then Needs_Finalization (Rng_Typ)) | |
3625 | then | |
3626 | Wrap_Loop_Statement (Manage_Sec_Stack => True); | |
ace11c95 | 3627 | Stop_Processing := True; |
abbfd698 HK |
3628 | end if; |
3629 | end if; | |
3630 | end Prepare_Param_Spec_Loop; | |
3631 | ||
3632 | ------------------------- | |
3633 | -- Wrap_Loop_Statement -- | |
3634 | ------------------------- | |
d6cd5d34 | 3635 | |
abbfd698 HK |
3636 | procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean) is |
3637 | Loc : constant Source_Ptr := Sloc (N); | |
3638 | ||
3639 | Blk : Node_Id; | |
3640 | Blk_Id : Entity_Id; | |
3641 | ||
3642 | begin | |
3643 | Blk := | |
3644 | Make_Block_Statement (Loc, | |
3645 | Declarations => New_List, | |
3646 | Handled_Statement_Sequence => | |
3647 | Make_Handled_Sequence_Of_Statements (Loc, | |
3648 | Statements => New_List (Relocate_Node (N)))); | |
3649 | ||
3650 | Add_Block_Identifier (Blk, Blk_Id); | |
3651 | Set_Uses_Sec_Stack (Blk_Id, Manage_Sec_Stack); | |
3652 | ||
3653 | Rewrite (N, Blk); | |
3654 | Analyze (N); | |
abbfd698 HK |
3655 | end Wrap_Loop_Statement; |
3656 | ||
3657 | -- Local variables | |
3658 | ||
3659 | Iter_Spec : constant Node_Id := Iterator_Specification (Iter); | |
3660 | Param_Spec : constant Node_Id := Loop_Parameter_Specification (Iter); | |
3661 | ||
3662 | -- Start of processing for Prepare_Loop_Statement | |
3663 | ||
3664 | begin | |
ace11c95 AC |
3665 | Stop_Processing := False; |
3666 | ||
abbfd698 | 3667 | if Present (Iter_Spec) then |
ace11c95 | 3668 | Prepare_Iterator_Loop (Iter_Spec, Stop_Processing); |
abbfd698 HK |
3669 | |
3670 | elsif Present (Param_Spec) then | |
ace11c95 | 3671 | Prepare_Param_Spec_Loop (Param_Spec, Stop_Processing); |
d6cd5d34 | 3672 | end if; |
abbfd698 | 3673 | end Prepare_Loop_Statement; |
ef992452 AC |
3674 | |
3675 | -- Local declarations | |
3676 | ||
3677 | Id : constant Node_Id := Identifier (N); | |
3678 | Iter : constant Node_Id := Iteration_Scheme (N); | |
3679 | Loc : constant Source_Ptr := Sloc (N); | |
2a806772 | 3680 | Ent : Entity_Id; |
d436b30d | 3681 | Stmt : Node_Id; |
996ae0b0 | 3682 | |
ef992452 AC |
3683 | -- Start of processing for Analyze_Loop_Statement |
3684 | ||
996ae0b0 RK |
3685 | begin |
3686 | if Present (Id) then | |
3687 | ||
176dadf6 AC |
3688 | -- Make name visible, e.g. for use in exit statements. Loop labels |
3689 | -- are always considered to be referenced. | |
996ae0b0 RK |
3690 | |
3691 | Analyze (Id); | |
3692 | Ent := Entity (Id); | |
996ae0b0 | 3693 | |
45fc7ddb HK |
3694 | -- Guard against serious error (typically, a scope mismatch when |
3695 | -- semantic analysis is requested) by creating loop entity to | |
3696 | -- continue analysis. | |
996ae0b0 | 3697 | |
45fc7ddb HK |
3698 | if No (Ent) then |
3699 | if Total_Errors_Detected /= 0 then | |
ef992452 | 3700 | Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); |
45fc7ddb HK |
3701 | else |
3702 | raise Program_Error; | |
3703 | end if; | |
3704 | ||
2afa8fdd AC |
3705 | -- Verify that the loop name is hot hidden by an unrelated |
3706 | -- declaration in an inner scope. | |
3707 | ||
bcb0389e | 3708 | elsif Ekind (Ent) /= E_Label and then Ekind (Ent) /= E_Loop then |
2afa8fdd AC |
3709 | Error_Msg_Sloc := Sloc (Ent); |
3710 | Error_Msg_N ("implicit label declaration for & is hidden#", Id); | |
3711 | ||
274d2584 ES |
3712 | if Present (Homonym (Ent)) |
3713 | and then Ekind (Homonym (Ent)) = E_Label | |
3714 | then | |
3715 | Set_Entity (Id, Ent); | |
3716 | Set_Ekind (Ent, E_Loop); | |
3717 | end if; | |
3718 | ||
45fc7ddb | 3719 | else |
ef992452 | 3720 | Generate_Reference (Ent, N, ' '); |
45fc7ddb | 3721 | Generate_Definition (Ent); |
996ae0b0 | 3722 | |
45fc7ddb HK |
3723 | -- If we found a label, mark its type. If not, ignore it, since it |
3724 | -- means we have a conflicting declaration, which would already | |
3725 | -- have been diagnosed at declaration time. Set Label_Construct | |
3726 | -- of the implicit label declaration, which is not created by the | |
3727 | -- parser for generic units. | |
3728 | ||
3729 | if Ekind (Ent) = E_Label then | |
3730 | Set_Ekind (Ent, E_Loop); | |
3731 | ||
3732 | if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then | |
ef992452 | 3733 | Set_Label_Construct (Parent (Ent), N); |
45fc7ddb | 3734 | end if; |
996ae0b0 RK |
3735 | end if; |
3736 | end if; | |
3737 | ||
03a72cd3 AC |
3738 | -- Case of no identifier present. Create one and attach it to the |
3739 | -- loop statement for use as a scope and as a reference for later | |
78cef47f AC |
3740 | -- expansions. Indicate that the label does not come from source, |
3741 | -- and attach it to the loop statement so it is part of the tree, | |
3742 | -- even without a full declaration. | |
996ae0b0 RK |
3743 | |
3744 | else | |
ef992452 AC |
3745 | Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); |
3746 | Set_Etype (Ent, Standard_Void_Type); | |
03a72cd3 | 3747 | Set_Identifier (N, New_Occurrence_Of (Ent, Loc)); |
78cef47f | 3748 | Set_Parent (Ent, N); |
03a72cd3 | 3749 | Set_Has_Created_Identifier (N); |
ef992452 | 3750 | end if; |
e11b776b | 3751 | |
abbfd698 HK |
3752 | -- Determine whether the loop statement must be transformed prior to |
3753 | -- analysis, and if so, perform it. This early modification is needed | |
3754 | -- when: | |
3755 | -- | |
3756 | -- * The loop has an erroneous iteration scheme. In this case the | |
3757 | -- loop is converted into an infinite loop in order to perform | |
3758 | -- minor analysis. | |
3759 | -- | |
3760 | -- * The loop is an Ada 2012 iterator loop. In this case the loop is | |
3761 | -- wrapped within a block to provide a local scope for the iterator. | |
3762 | -- If the iterator specification requires the secondary stack in any | |
3763 | -- way, the block is marked in order to manage it. | |
3764 | -- | |
3765 | -- * The loop is using a parameter specification where the discrete | |
3766 | -- range requires the secondary stack. In this case the loop is | |
3767 | -- wrapped within a block in order to manage the secondary stack. | |
e8427749 | 3768 | |
abbfd698 | 3769 | if Present (Iter) then |
ace11c95 AC |
3770 | declare |
3771 | Stop_Processing : Boolean; | |
3772 | begin | |
3773 | Prepare_Loop_Statement (Iter, Stop_Processing); | |
3774 | ||
3775 | if Stop_Processing then | |
3776 | return; | |
3777 | end if; | |
3778 | end; | |
e8427749 JM |
3779 | end if; |
3780 | ||
176dadf6 AC |
3781 | -- Kill current values on entry to loop, since statements in the body of |
3782 | -- the loop may have been executed before the loop is entered. Similarly | |
3783 | -- we kill values after the loop, since we do not know that the body of | |
3784 | -- the loop was executed. | |
fbf5a39b AC |
3785 | |
3786 | Kill_Current_Values; | |
27c489df | 3787 | Push_Scope (Ent); |
2a806772 | 3788 | Analyze_Iteration_Scheme (Iter); |
4637729f | 3789 | |
30ebb114 AC |
3790 | -- Check for following case which merits a warning if the type E of is |
3791 | -- a multi-dimensional array (and no explicit subscript ranges present). | |
3792 | ||
3793 | -- for J in E'Range | |
3794 | -- for K in E'Range | |
3795 | ||
3796 | if Present (Iter) | |
3797 | and then Present (Loop_Parameter_Specification (Iter)) | |
3798 | then | |
3799 | declare | |
3800 | LPS : constant Node_Id := Loop_Parameter_Specification (Iter); | |
3801 | DSD : constant Node_Id := | |
3802 | Original_Node (Discrete_Subtype_Definition (LPS)); | |
3803 | begin | |
3804 | if Nkind (DSD) = N_Attribute_Reference | |
3805 | and then Attribute_Name (DSD) = Name_Range | |
3806 | and then No (Expressions (DSD)) | |
3807 | then | |
3808 | declare | |
3809 | Typ : constant Entity_Id := Etype (Prefix (DSD)); | |
3810 | begin | |
3811 | if Is_Array_Type (Typ) | |
3812 | and then Number_Dimensions (Typ) > 1 | |
3813 | and then Nkind (Parent (N)) = N_Loop_Statement | |
3814 | and then Present (Iteration_Scheme (Parent (N))) | |
3815 | then | |
3816 | declare | |
3817 | OIter : constant Node_Id := | |
3818 | Iteration_Scheme (Parent (N)); | |
3819 | OLPS : constant Node_Id := | |
3820 | Loop_Parameter_Specification (OIter); | |
3821 | ODSD : constant Node_Id := | |
3822 | Original_Node (Discrete_Subtype_Definition (OLPS)); | |
3823 | begin | |
3824 | if Nkind (ODSD) = N_Attribute_Reference | |
3825 | and then Attribute_Name (ODSD) = Name_Range | |
3826 | and then No (Expressions (ODSD)) | |
3827 | and then Etype (Prefix (ODSD)) = Typ | |
3828 | then | |
3829 | Error_Msg_Sloc := Sloc (ODSD); | |
3830 | Error_Msg_N | |
324ac540 | 3831 | ("inner range same as outer range#??", DSD); |
30ebb114 AC |
3832 | end if; |
3833 | end; | |
3834 | end if; | |
3835 | end; | |
3836 | end if; | |
3837 | end; | |
3838 | end if; | |
3839 | ||
4637729f AC |
3840 | -- Analyze the statements of the body except in the case of an Ada 2012 |
3841 | -- iterator with the expander active. In this case the expander will do | |
3842 | -- a rewrite of the loop into a while loop. We will then analyze the | |
3843 | -- loop body when we analyze this while loop. | |
3844 | ||
3845 | -- We need to do this delay because if the container is for indefinite | |
3846 | -- types the actual subtype of the components will only be determined | |
3847 | -- when the cursor declaration is analyzed. | |
3848 | ||
fc90cc62 AC |
3849 | -- If the expander is not active then we want to analyze the loop body |
3850 | -- now even in the Ada 2012 iterator case, since the rewriting will not | |
3851 | -- be done. Insert the loop variable in the current scope, if not done | |
64ac53f4 | 3852 | -- when analysing the iteration scheme. Set its kind properly to detect |
fc90cc62 AC |
3853 | -- improper uses in the loop body. |
3854 | ||
3855 | -- In GNATprove mode, we do one of the above depending on the kind of | |
3856 | -- loop. If it is an iterator over an array, then we do not analyze the | |
3857 | -- loop now. We will analyze it after it has been rewritten by the | |
3858 | -- special SPARK expansion which is activated in GNATprove mode. We need | |
3859 | -- to do this so that other expansions that should occur in GNATprove | |
3860 | -- mode take into account the specificities of the rewritten loop, in | |
3861 | -- particular the introduction of a renaming (which needs to be | |
3862 | -- expanded). | |
3863 | ||
3864 | -- In other cases in GNATprove mode then we want to analyze the loop | |
6b1d2413 AC |
3865 | -- body now, since no rewriting will occur. Within a generic the |
3866 | -- GNATprove mode is irrelevant, we must analyze the generic for | |
3867 | -- non-local name capture. | |
4637729f | 3868 | |
8f4a8bef AC |
3869 | if Present (Iter) |
3870 | and then Present (Iterator_Specification (Iter)) | |
4637729f | 3871 | then |
fc90cc62 AC |
3872 | if GNATprove_Mode |
3873 | and then Is_Iterator_Over_Array (Iterator_Specification (Iter)) | |
6b1d2413 | 3874 | and then not Inside_A_Generic |
fc90cc62 AC |
3875 | then |
3876 | null; | |
3877 | ||
3878 | elsif not Expander_Active then | |
36b8f95f | 3879 | declare |
8f4a8bef AC |
3880 | I_Spec : constant Node_Id := Iterator_Specification (Iter); |
3881 | Id : constant Entity_Id := Defining_Identifier (I_Spec); | |
3882 | ||
36b8f95f AC |
3883 | begin |
3884 | if Scope (Id) /= Current_Scope then | |
3885 | Enter_Name (Id); | |
3886 | end if; | |
8f4a8bef | 3887 | |
e8bb6ff9 | 3888 | -- In an element iterator, the loop parameter is a variable if |
8f4a8bef AC |
3889 | -- the domain of iteration (container or array) is a variable. |
3890 | ||
3891 | if not Of_Present (I_Spec) | |
3892 | or else not Is_Variable (Name (I_Spec)) | |
3893 | then | |
3894 | Set_Ekind (Id, E_Loop_Parameter); | |
3895 | end if; | |
36b8f95f | 3896 | end; |
8f4a8bef AC |
3897 | |
3898 | Analyze_Statements (Statements (N)); | |
36b8f95f AC |
3899 | end if; |
3900 | ||
8f4a8bef | 3901 | else |
90e491a7 | 3902 | -- Pre-Ada2012 for-loops and while loops |
8f4a8bef | 3903 | |
ef992452 | 3904 | Analyze_Statements (Statements (N)); |
4637729f AC |
3905 | end if; |
3906 | ||
e4ef65f9 AC |
3907 | -- If the loop has no side effects, mark it for removal. |
3908 | ||
3909 | if Side_Effect_Free_Loop (N) then | |
3910 | Set_Is_Null_Loop (N); | |
3911 | end if; | |
3912 | ||
d436b30d AC |
3913 | -- When the iteration scheme of a loop contains attribute 'Loop_Entry, |
3914 | -- the loop is transformed into a conditional block. Retrieve the loop. | |
3915 | ||
3916 | Stmt := N; | |
3917 | ||
3918 | if Subject_To_Loop_Entry_Attributes (Stmt) then | |
3919 | Stmt := Find_Loop_In_Conditional_Block (Stmt); | |
3920 | end if; | |
3921 | ||
4637729f AC |
3922 | -- Finish up processing for the loop. We kill all current values, since |
3923 | -- in general we don't know if the statements in the loop have been | |
3924 | -- executed. We could do a bit better than this with a loop that we | |
3925 | -- know will execute at least once, but it's not worth the trouble and | |
3926 | -- the front end is not in the business of flow tracing. | |
3927 | ||
d436b30d | 3928 | Process_End_Label (Stmt, 'e', Ent); |
996ae0b0 | 3929 | End_Scope; |
fbf5a39b | 3930 | Kill_Current_Values; |
4a13695c | 3931 | |
51bf9bdf AC |
3932 | -- Check for infinite loop. Skip check for generated code, since it |
3933 | -- justs waste time and makes debugging the routine called harder. | |
3934 | ||
3935 | -- Note that we have to wait till the body of the loop is fully analyzed | |
3936 | -- before making this call, since Check_Infinite_Loop_Warning relies on | |
3937 | -- being able to use semantic visibility information to find references. | |
4a13695c | 3938 | |
d436b30d AC |
3939 | if Comes_From_Source (Stmt) then |
3940 | Check_Infinite_Loop_Warning (Stmt); | |
4a13695c | 3941 | end if; |
45fc7ddb | 3942 | |
176dadf6 AC |
3943 | -- Code after loop is unreachable if the loop has no WHILE or FOR and |
3944 | -- contains no EXIT statements within the body of the loop. | |
45fc7ddb HK |
3945 | |
3946 | if No (Iter) and then not Has_Exit (Ent) then | |
d436b30d | 3947 | Check_Unreachable_Code (Stmt); |
45fc7ddb | 3948 | end if; |
996ae0b0 RK |
3949 | end Analyze_Loop_Statement; |
3950 | ||
3951 | ---------------------------- | |
3952 | -- Analyze_Null_Statement -- | |
3953 | ---------------------------- | |
3954 | ||
3955 | -- Note: the semantics of the null statement is implemented by a single | |
a90bd866 | 3956 | -- null statement, too bad everything isn't as simple as this. |
996ae0b0 RK |
3957 | |
3958 | procedure Analyze_Null_Statement (N : Node_Id) is | |
07fc65c4 | 3959 | pragma Warnings (Off, N); |
996ae0b0 RK |
3960 | begin |
3961 | null; | |
3962 | end Analyze_Null_Statement; | |
3963 | ||
ae33543c ES |
3964 | ------------------------- |
3965 | -- Analyze_Target_Name -- | |
3966 | ------------------------- | |
3967 | ||
3968 | procedure Analyze_Target_Name (N : Node_Id) is | |
3969 | begin | |
f8a21934 AC |
3970 | -- A target name has the type of the left-hand side of the enclosing |
3971 | -- assignment. | |
d43584ca | 3972 | |
f8a21934 | 3973 | Set_Etype (N, Etype (Name (Current_Assignment))); |
ae33543c ES |
3974 | end Analyze_Target_Name; |
3975 | ||
996ae0b0 RK |
3976 | ------------------------ |
3977 | -- Analyze_Statements -- | |
3978 | ------------------------ | |
3979 | ||
3980 | procedure Analyze_Statements (L : List_Id) is | |
fbf5a39b | 3981 | Lab : Entity_Id; |
b6e6a4e3 | 3982 | S : Node_Id; |
996ae0b0 RK |
3983 | |
3984 | begin | |
3985 | -- The labels declared in the statement list are reachable from | |
176dadf6 AC |
3986 | -- statements in the list. We do this as a prepass so that any goto |
3987 | -- statement will be properly flagged if its target is not reachable. | |
a90bd866 | 3988 | -- This is not required, but is nice behavior. |
996ae0b0 RK |
3989 | |
3990 | S := First (L); | |
996ae0b0 RK |
3991 | while Present (S) loop |
3992 | if Nkind (S) = N_Label then | |
fbf5a39b AC |
3993 | Analyze (Identifier (S)); |
3994 | Lab := Entity (Identifier (S)); | |
3995 | ||
e2d6a9e5 | 3996 | -- If we found a label mark it as reachable |
fbf5a39b AC |
3997 | |
3998 | if Ekind (Lab) = E_Label then | |
3999 | Generate_Definition (Lab); | |
4000 | Set_Reachable (Lab); | |
4001 | ||
4002 | if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then | |
4003 | Set_Label_Construct (Parent (Lab), S); | |
4004 | end if; | |
4005 | ||
4006 | -- If we failed to find a label, it means the implicit declaration | |
64ac53f4 | 4007 | -- of the label was hidden. A for-loop parameter can do this to |
fbf5a39b AC |
4008 | -- a label with the same name inside the loop, since the implicit |
4009 | -- label declaration is in the innermost enclosing body or block | |
4010 | -- statement. | |
4011 | ||
4012 | else | |
4013 | Error_Msg_Sloc := Sloc (Lab); | |
4014 | Error_Msg_N | |
4015 | ("implicit label declaration for & is hidden#", | |
4016 | Identifier (S)); | |
4017 | end if; | |
996ae0b0 RK |
4018 | end if; |
4019 | ||
4020 | Next (S); | |
4021 | end loop; | |
4022 | ||
4023 | -- Perform semantic analysis on all statements | |
4024 | ||
fbf5a39b | 4025 | Conditional_Statements_Begin; |
996ae0b0 | 4026 | |
fbf5a39b | 4027 | S := First (L); |
996ae0b0 | 4028 | while Present (S) loop |
fbf5a39b | 4029 | Analyze (S); |
dec6faf1 AC |
4030 | |
4031 | -- Remove dimension in all statements | |
4032 | ||
4033 | Remove_Dimension_In_Statement (S); | |
996ae0b0 RK |
4034 | Next (S); |
4035 | end loop; | |
4036 | ||
fbf5a39b AC |
4037 | Conditional_Statements_End; |
4038 | ||
176dadf6 AC |
4039 | -- Make labels unreachable. Visibility is not sufficient, because labels |
4040 | -- in one if-branch for example are not reachable from the other branch, | |
4041 | -- even though their declarations are in the enclosing declarative part. | |
996ae0b0 RK |
4042 | |
4043 | S := First (L); | |
996ae0b0 RK |
4044 | while Present (S) loop |
4045 | if Nkind (S) = N_Label then | |
4046 | Set_Reachable (Entity (Identifier (S)), False); | |
4047 | end if; | |
4048 | ||
4049 | Next (S); | |
4050 | end loop; | |
4051 | end Analyze_Statements; | |
4052 | ||
4053 | ---------------------------- | |
4054 | -- Check_Unreachable_Code -- | |
4055 | ---------------------------- | |
4056 | ||
4057 | procedure Check_Unreachable_Code (N : Node_Id) is | |
23685ae6 AC |
4058 | Error_Node : Node_Id; |
4059 | P : Node_Id; | |
996ae0b0 RK |
4060 | |
4061 | begin | |
ac7d724d | 4062 | if Is_List_Member (N) and then Comes_From_Source (N) then |
996ae0b0 RK |
4063 | declare |
4064 | Nxt : Node_Id; | |
4065 | ||
4066 | begin | |
4067 | Nxt := Original_Node (Next (N)); | |
4068 | ||
f146302c AC |
4069 | -- Skip past pragmas |
4070 | ||
4071 | while Nkind (Nxt) = N_Pragma loop | |
4072 | Nxt := Original_Node (Next (Nxt)); | |
4073 | end loop; | |
4074 | ||
6f21ed26 | 4075 | -- If a label follows us, then we never have dead code, since |
7907619e | 4076 | -- someone could branch to the label, so we just ignore it. |
6f21ed26 | 4077 | |
7907619e | 4078 | if Nkind (Nxt) = N_Label then |
6f21ed26 RD |
4079 | return; |
4080 | ||
4081 | -- Otherwise see if we have a real statement following us | |
4082 | ||
4083 | elsif Present (Nxt) | |
996ae0b0 RK |
4084 | and then Comes_From_Source (Nxt) |
4085 | and then Is_Statement (Nxt) | |
4086 | then | |
4087 | -- Special very annoying exception. If we have a return that | |
4088 | -- follows a raise, then we allow it without a warning, since | |
a90bd866 | 4089 | -- the Ada RM annoyingly requires a useless return here. |
996ae0b0 RK |
4090 | |
4091 | if Nkind (Original_Node (N)) /= N_Raise_Statement | |
1b6c95c4 | 4092 | or else Nkind (Nxt) /= N_Simple_Return_Statement |
996ae0b0 RK |
4093 | then |
4094 | -- The rather strange shenanigans with the warning message | |
4095 | -- here reflects the fact that Kill_Dead_Code is very good | |
4096 | -- at removing warnings in deleted code, and this is one | |
27c489df | 4097 | -- warning we would prefer NOT to have removed. |
996ae0b0 | 4098 | |
23685ae6 | 4099 | Error_Node := Nxt; |
996ae0b0 RK |
4100 | |
4101 | -- If we have unreachable code, analyze and remove the | |
4102 | -- unreachable code, since it is useless and we don't | |
4103 | -- want to generate junk warnings. | |
4104 | ||
b8b2d982 AC |
4105 | -- We skip this step if we are not in code generation mode |
4106 | -- or CodePeer mode. | |
a08bf2de | 4107 | |
996ae0b0 RK |
4108 | -- This is the one case where we remove dead code in the |
4109 | -- semantics as opposed to the expander, and we do not want | |
4110 | -- to remove code if we are not in code generation mode, | |
3aeb5ebe AC |
4111 | -- since this messes up the tree or loses useful information |
4112 | -- for CodePeer. | |
996ae0b0 RK |
4113 | |
4114 | -- Note that one might react by moving the whole circuit to | |
4115 | -- exp_ch5, but then we lose the warning in -gnatc mode. | |
4116 | ||
b8b2d982 AC |
4117 | if Operating_Mode = Generate_Code |
4118 | and then not CodePeer_Mode | |
4119 | then | |
996ae0b0 RK |
4120 | loop |
4121 | Nxt := Next (N); | |
fbf5a39b AC |
4122 | |
4123 | -- Quit deleting when we have nothing more to delete | |
4124 | -- or if we hit a label (since someone could transfer | |
4125 | -- control to a label, so we should not delete it). | |
4126 | ||
4127 | exit when No (Nxt) or else Nkind (Nxt) = N_Label; | |
4128 | ||
4129 | -- Statement/declaration is to be deleted | |
4130 | ||
996ae0b0 RK |
4131 | Analyze (Nxt); |
4132 | Remove (Nxt); | |
4133 | Kill_Dead_Code (Nxt); | |
4134 | end loop; | |
4135 | end if; | |
4136 | ||
7907619e AC |
4137 | Error_Msg |
4138 | ("??unreachable code!", Sloc (Error_Node), Error_Node); | |
996ae0b0 RK |
4139 | end if; |
4140 | ||
176dadf6 AC |
4141 | -- If the unconditional transfer of control instruction is the |
4142 | -- last statement of a sequence, then see if our parent is one of | |
4143 | -- the constructs for which we count unblocked exits, and if so, | |
4144 | -- adjust the count. | |
996ae0b0 RK |
4145 | |
4146 | else | |
4147 | P := Parent (N); | |
4148 | ||
6f21ed26 RD |
4149 | -- Statements in THEN part or ELSE part of IF statement |
4150 | ||
996ae0b0 RK |
4151 | if Nkind (P) = N_If_Statement then |
4152 | null; | |
4153 | ||
6f21ed26 RD |
4154 | -- Statements in ELSIF part of an IF statement |
4155 | ||
996ae0b0 RK |
4156 | elsif Nkind (P) = N_Elsif_Part then |
4157 | P := Parent (P); | |
4158 | pragma Assert (Nkind (P) = N_If_Statement); | |
4159 | ||
6f21ed26 RD |
4160 | -- Statements in CASE statement alternative |
4161 | ||
996ae0b0 RK |
4162 | elsif Nkind (P) = N_Case_Statement_Alternative then |
4163 | P := Parent (P); | |
4164 | pragma Assert (Nkind (P) = N_Case_Statement); | |
4165 | ||
6f21ed26 RD |
4166 | -- Statements in body of block |
4167 | ||
4168 | elsif Nkind (P) = N_Handled_Sequence_Of_Statements | |
4169 | and then Nkind (Parent (P)) = N_Block_Statement | |
4170 | then | |
3d67b239 AC |
4171 | -- The original loop is now placed inside a block statement |
4172 | -- due to the expansion of attribute 'Loop_Entry. Return as | |
4173 | -- this is not a "real" block for the purposes of exit | |
4174 | -- counting. | |
4175 | ||
4176 | if Nkind (N) = N_Loop_Statement | |
4177 | and then Subject_To_Loop_Entry_Attributes (N) | |
4178 | then | |
4179 | return; | |
4180 | end if; | |
6f21ed26 RD |
4181 | |
4182 | -- Statements in exception handler in a block | |
4183 | ||
4184 | elsif Nkind (P) = N_Exception_Handler | |
4185 | and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements | |
4186 | and then Nkind (Parent (Parent (P))) = N_Block_Statement | |
4187 | then | |
4188 | null; | |
4189 | ||
4190 | -- None of these cases, so return | |
4191 | ||
996ae0b0 RK |
4192 | else |
4193 | return; | |
4194 | end if; | |
4195 | ||
6f21ed26 RD |
4196 | -- This was one of the cases we are looking for (i.e. the |
4197 | -- parent construct was IF, CASE or block) so decrement count. | |
4198 | ||
996ae0b0 RK |
4199 | Unblocked_Exit_Count := Unblocked_Exit_Count - 1; |
4200 | end if; | |
4201 | end; | |
4202 | end if; | |
4203 | end Check_Unreachable_Code; | |
4204 | ||
abbfd698 HK |
4205 | ------------------------ |
4206 | -- Has_Sec_Stack_Call -- | |
4207 | ------------------------ | |
e8427749 | 4208 | |
abbfd698 | 4209 | function Has_Sec_Stack_Call (N : Node_Id) return Boolean is |
e8427749 JM |
4210 | function Check_Call (N : Node_Id) return Traverse_Result; |
4211 | -- Check if N is a function call which uses the secondary stack | |
4212 | ||
4213 | ---------------- | |
4214 | -- Check_Call -- | |
4215 | ---------------- | |
4216 | ||
4217 | function Check_Call (N : Node_Id) return Traverse_Result is | |
4218 | Nam : Node_Id; | |
4219 | Subp : Entity_Id; | |
4220 | Typ : Entity_Id; | |
4221 | ||
4222 | begin | |
4223 | if Nkind (N) = N_Function_Call then | |
4224 | Nam := Name (N); | |
4225 | ||
4226 | -- Obtain the subprogram being invoked | |
4227 | ||
4228 | loop | |
4229 | if Nkind (Nam) = N_Explicit_Dereference then | |
4230 | Nam := Prefix (Nam); | |
4231 | ||
4232 | elsif Nkind (Nam) = N_Selected_Component then | |
4233 | Nam := Selector_Name (Nam); | |
4234 | ||
4235 | else | |
4236 | exit; | |
4237 | end if; | |
4238 | end loop; | |
4239 | ||
4240 | Subp := Entity (Nam); | |
e8427749 | 4241 | |
abbfd698 HK |
4242 | if Present (Subp) then |
4243 | Typ := Etype (Subp); | |
e8427749 | 4244 | |
abbfd698 HK |
4245 | if Requires_Transient_Scope (Typ) then |
4246 | return Abandon; | |
4247 | ||
4248 | elsif Sec_Stack_Needed_For_Return (Subp) then | |
4249 | return Abandon; | |
4250 | end if; | |
e8427749 JM |
4251 | end if; |
4252 | end if; | |
4253 | ||
4254 | -- Continue traversing the tree | |
4255 | ||
4256 | return OK; | |
4257 | end Check_Call; | |
4258 | ||
4259 | function Check_Calls is new Traverse_Func (Check_Call); | |
4260 | ||
abbfd698 | 4261 | -- Start of processing for Has_Sec_Stack_Call |
e8427749 JM |
4262 | |
4263 | begin | |
4264 | return Check_Calls (N) = Abandon; | |
abbfd698 | 4265 | end Has_Sec_Stack_Call; |
e8427749 | 4266 | |
804670f1 AC |
4267 | ---------------------- |
4268 | -- Preanalyze_Range -- | |
4269 | ---------------------- | |
ef992452 | 4270 | |
804670f1 | 4271 | procedure Preanalyze_Range (R_Copy : Node_Id) is |
ef992452 | 4272 | Save_Analysis : constant Boolean := Full_Analysis; |
e8e581cd | 4273 | Typ : Entity_Id; |
ef992452 AC |
4274 | |
4275 | begin | |
4276 | Full_Analysis := False; | |
4277 | Expander_Mode_Save_And_Set (False); | |
4278 | ||
b45a9ff3 JS |
4279 | -- In addition to the above we must explicitly suppress the generation |
4280 | -- of freeze nodes that might otherwise be generated during resolution | |
4281 | -- of the range (e.g. if given by an attribute that will freeze its | |
4282 | -- prefix). | |
a0fa5497 ES |
4283 | |
4284 | Set_Must_Not_Freeze (R_Copy); | |
4285 | ||
4286 | if Nkind (R_Copy) = N_Attribute_Reference then | |
4287 | Set_Must_Not_Freeze (Prefix (R_Copy)); | |
4288 | end if; | |
4289 | ||
ef992452 AC |
4290 | Analyze (R_Copy); |
4291 | ||
ac7d724d ES |
4292 | if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then |
4293 | ||
ef992452 | 4294 | -- Apply preference rules for range of predefined integer types, or |
820f1162 | 4295 | -- check for array or iterable construct for "of" iterator, or |
ef992452 AC |
4296 | -- diagnose true ambiguity. |
4297 | ||
4298 | declare | |
4299 | I : Interp_Index; | |
4300 | It : Interp; | |
4301 | Found : Entity_Id := Empty; | |
4302 | ||
4303 | begin | |
4304 | Get_First_Interp (R_Copy, I, It); | |
4305 | while Present (It.Typ) loop | |
4306 | if Is_Discrete_Type (It.Typ) then | |
4307 | if No (Found) then | |
4308 | Found := It.Typ; | |
4309 | else | |
4310 | if Scope (Found) = Standard_Standard then | |
4311 | null; | |
4312 | ||
4313 | elsif Scope (It.Typ) = Standard_Standard then | |
4314 | Found := It.Typ; | |
4315 | ||
4316 | else | |
4317 | -- Both of them are user-defined | |
4318 | ||
4319 | Error_Msg_N | |
4320 | ("ambiguous bounds in range of iteration", R_Copy); | |
4321 | Error_Msg_N ("\possible interpretations:", R_Copy); | |
4322 | Error_Msg_NE ("\\} ", R_Copy, Found); | |
4323 | Error_Msg_NE ("\\} ", R_Copy, It.Typ); | |
4324 | exit; | |
4325 | end if; | |
4326 | end if; | |
820f1162 AC |
4327 | |
4328 | elsif Nkind (Parent (R_Copy)) = N_Iterator_Specification | |
4329 | and then Of_Present (Parent (R_Copy)) | |
4330 | then | |
4331 | if Is_Array_Type (It.Typ) | |
4332 | or else Has_Aspect (It.Typ, Aspect_Iterator_Element) | |
4333 | or else Has_Aspect (It.Typ, Aspect_Constant_Indexing) | |
4334 | or else Has_Aspect (It.Typ, Aspect_Variable_Indexing) | |
4335 | then | |
4336 | if No (Found) then | |
4337 | Found := It.Typ; | |
4338 | Set_Etype (R_Copy, It.Typ); | |
4339 | ||
4340 | else | |
d1eb8a82 | 4341 | Error_Msg_N ("ambiguous domain of iteration", R_Copy); |
820f1162 AC |
4342 | end if; |
4343 | end if; | |
ef992452 AC |
4344 | end if; |
4345 | ||
4346 | Get_Next_Interp (I, It); | |
4347 | end loop; | |
4348 | end; | |
4349 | end if; | |
4350 | ||
4351 | -- Subtype mark in iteration scheme | |
4352 | ||
ac7d724d | 4353 | if Is_Entity_Name (R_Copy) and then Is_Type (Entity (R_Copy)) then |
ef992452 AC |
4354 | null; |
4355 | ||
4356 | -- Expression in range, or Ada 2012 iterator | |
4357 | ||
4358 | elsif Nkind (R_Copy) in N_Subexpr then | |
4359 | Resolve (R_Copy); | |
e8e581cd AC |
4360 | Typ := Etype (R_Copy); |
4361 | ||
4362 | if Is_Discrete_Type (Typ) then | |
4363 | null; | |
4364 | ||
570104df | 4365 | -- Check that the resulting object is an iterable container |
e8e581cd | 4366 | |
d62520f3 HK |
4367 | elsif Has_Aspect (Typ, Aspect_Iterator_Element) |
4368 | or else Has_Aspect (Typ, Aspect_Constant_Indexing) | |
4369 | or else Has_Aspect (Typ, Aspect_Variable_Indexing) | |
e8e581cd AC |
4370 | then |
4371 | null; | |
4372 | ||
570104df | 4373 | -- The expression may yield an implicit reference to an iterable |
e8e581cd AC |
4374 | -- container. Insert explicit dereference so that proper type is |
4375 | -- visible in the loop. | |
4376 | ||
4377 | elsif Has_Implicit_Dereference (Etype (R_Copy)) then | |
44599998 EB |
4378 | Build_Explicit_Dereference |
4379 | (R_Copy, Get_Reference_Discriminant (Etype (R_Copy))); | |
e8e581cd | 4380 | end if; |
ef992452 AC |
4381 | end if; |
4382 | ||
4383 | Expander_Mode_Restore; | |
4384 | Full_Analysis := Save_Analysis; | |
804670f1 | 4385 | end Preanalyze_Range; |
ef992452 | 4386 | |
996ae0b0 | 4387 | end Sem_Ch5; |