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