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