]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C H 5 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
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 -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
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; | |
32 | with Exp_Util; use Exp_Util; | |
33 | with Freeze; use Freeze; | |
34 | with Lib.Xref; use Lib.Xref; | |
35 | with Nlists; use Nlists; | |
36 | with Opt; use Opt; | |
37 | with Sem; use Sem; | |
38 | with Sem_Case; use Sem_Case; | |
39 | with Sem_Ch3; use Sem_Ch3; | |
40 | with Sem_Ch8; use Sem_Ch8; | |
41 | with Sem_Disp; use Sem_Disp; | |
42 | with Sem_Eval; use Sem_Eval; | |
43 | with Sem_Res; use Sem_Res; | |
44 | with Sem_Type; use Sem_Type; | |
45 | with Sem_Util; use Sem_Util; | |
46 | with Sem_Warn; use Sem_Warn; | |
47 | with Stand; use Stand; | |
48 | with Sinfo; use Sinfo; | |
fbf5a39b | 49 | with Targparm; use Targparm; |
996ae0b0 RK |
50 | with Tbuild; use Tbuild; |
51 | with Uintp; use Uintp; | |
52 | ||
53 | package body Sem_Ch5 is | |
54 | ||
55 | Unblocked_Exit_Count : Nat := 0; | |
56 | -- This variable is used when processing if statements or case | |
57 | -- statements, it counts the number of branches of the conditional | |
58 | -- that are not blocked by unconditional transfer instructions. At | |
59 | -- the end of processing, if the count is zero, it means that control | |
60 | -- cannot fall through the conditional statement. This is used for | |
61 | -- the generation of warning messages. This variable is recursively | |
62 | -- saved on entry to processing an if or case, and restored on exit. | |
63 | ||
64 | ----------------------- | |
65 | -- Local Subprograms -- | |
66 | ----------------------- | |
67 | ||
68 | procedure Analyze_Iteration_Scheme (N : Node_Id); | |
69 | ||
fbf5a39b AC |
70 | procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id); |
71 | -- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme | |
72 | -- (the latter when a WHILE condition is present). This call checks | |
73 | -- if Condition (Cnode) is of the form ([NOT] var op val), where var | |
74 | -- is a simple object, val is known at compile time, and op is one | |
75 | -- of the six relational operators. If this is the case, and the | |
76 | -- Current_Value field of "var" is not set, then it is set to Cnode. | |
77 | -- See Exp_Util.Set_Current_Value_Condition for further details. | |
78 | ||
996ae0b0 RK |
79 | ------------------------ |
80 | -- Analyze_Assignment -- | |
81 | ------------------------ | |
82 | ||
83 | procedure Analyze_Assignment (N : Node_Id) is | |
fbf5a39b AC |
84 | Lhs : constant Node_Id := Name (N); |
85 | Rhs : constant Node_Id := Expression (N); | |
86 | T1 : Entity_Id; | |
87 | T2 : Entity_Id; | |
88 | Decl : Node_Id; | |
89 | Ent : Entity_Id; | |
996ae0b0 RK |
90 | |
91 | procedure Diagnose_Non_Variable_Lhs (N : Node_Id); | |
92 | -- N is the node for the left hand side of an assignment, and it | |
93 | -- is not a variable. This routine issues an appropriate diagnostic. | |
94 | ||
95 | procedure Set_Assignment_Type | |
96 | (Opnd : Node_Id; | |
97 | Opnd_Type : in out Entity_Id); | |
98 | -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type | |
99 | -- is the nominal subtype. This procedure is used to deal with cases | |
100 | -- where the nominal subtype must be replaced by the actual subtype. | |
101 | ||
102 | ------------------------------- | |
103 | -- Diagnose_Non_Variable_Lhs -- | |
104 | ------------------------------- | |
105 | ||
106 | procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is | |
107 | begin | |
108 | -- Not worth posting another error if left hand side already | |
109 | -- flagged as being illegal in some respect | |
110 | ||
111 | if Error_Posted (N) then | |
112 | return; | |
113 | ||
114 | -- Some special bad cases of entity names | |
115 | ||
116 | elsif Is_Entity_Name (N) then | |
117 | ||
118 | if Ekind (Entity (N)) = E_In_Parameter then | |
119 | Error_Msg_N | |
120 | ("assignment to IN mode parameter not allowed", N); | |
121 | return; | |
122 | ||
123 | -- Private declarations in a protected object are turned into | |
124 | -- constants when compiling a protected function. | |
125 | ||
126 | elsif Present (Scope (Entity (N))) | |
127 | and then Is_Protected_Type (Scope (Entity (N))) | |
128 | and then | |
129 | (Ekind (Current_Scope) = E_Function | |
130 | or else | |
131 | Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function) | |
132 | then | |
133 | Error_Msg_N | |
134 | ("protected function cannot modify protected object", N); | |
135 | return; | |
136 | ||
137 | elsif Ekind (Entity (N)) = E_Loop_Parameter then | |
138 | Error_Msg_N | |
139 | ("assignment to loop parameter not allowed", N); | |
140 | return; | |
141 | ||
142 | end if; | |
143 | ||
144 | -- For indexed components, or selected components, test prefix | |
145 | ||
146 | elsif Nkind (N) = N_Indexed_Component | |
147 | or else Nkind (N) = N_Selected_Component | |
148 | then | |
149 | Diagnose_Non_Variable_Lhs (Prefix (N)); | |
150 | return; | |
151 | end if; | |
152 | ||
153 | -- If we fall through, we have no special message to issue! | |
154 | ||
155 | Error_Msg_N ("left hand side of assignment must be a variable", N); | |
996ae0b0 RK |
156 | end Diagnose_Non_Variable_Lhs; |
157 | ||
158 | ------------------------- | |
159 | -- Set_Assignment_Type -- | |
160 | ------------------------- | |
161 | ||
162 | procedure Set_Assignment_Type | |
163 | (Opnd : Node_Id; | |
164 | Opnd_Type : in out Entity_Id) | |
165 | is | |
166 | begin | |
fbf5a39b AC |
167 | Require_Entity (Opnd); |
168 | ||
996ae0b0 RK |
169 | -- If the assignment operand is an in-out or out parameter, then we |
170 | -- get the actual subtype (needed for the unconstrained case). | |
fbf5a39b AC |
171 | -- If the operand is the actual in an entry declaration, then within |
172 | -- the accept statement it is replaced with a local renaming, which | |
173 | -- may also have an actual subtype. | |
996ae0b0 RK |
174 | |
175 | if Is_Entity_Name (Opnd) | |
176 | and then (Ekind (Entity (Opnd)) = E_Out_Parameter | |
177 | or else Ekind (Entity (Opnd)) = | |
178 | E_In_Out_Parameter | |
179 | or else Ekind (Entity (Opnd)) = | |
fbf5a39b AC |
180 | E_Generic_In_Out_Parameter |
181 | or else | |
182 | (Ekind (Entity (Opnd)) = E_Variable | |
183 | and then Nkind (Parent (Entity (Opnd))) = | |
184 | N_Object_Renaming_Declaration | |
185 | and then Nkind (Parent (Parent (Entity (Opnd)))) = | |
186 | N_Accept_Statement)) | |
996ae0b0 RK |
187 | then |
188 | Opnd_Type := Get_Actual_Subtype (Opnd); | |
189 | ||
190 | -- If assignment operand is a component reference, then we get the | |
191 | -- actual subtype of the component for the unconstrained case. | |
192 | ||
fbf5a39b AC |
193 | elsif |
194 | (Nkind (Opnd) = N_Selected_Component | |
195 | or else Nkind (Opnd) = N_Explicit_Dereference) | |
196 | and then not Is_Unchecked_Union (Opnd_Type) | |
996ae0b0 RK |
197 | then |
198 | Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd); | |
199 | ||
200 | if Present (Decl) then | |
201 | Insert_Action (N, Decl); | |
202 | Mark_Rewrite_Insertion (Decl); | |
203 | Analyze (Decl); | |
204 | Opnd_Type := Defining_Identifier (Decl); | |
205 | Set_Etype (Opnd, Opnd_Type); | |
206 | Freeze_Itype (Opnd_Type, N); | |
207 | ||
208 | elsif Is_Constrained (Etype (Opnd)) then | |
209 | Opnd_Type := Etype (Opnd); | |
210 | end if; | |
211 | ||
212 | -- For slice, use the constrained subtype created for the slice | |
213 | ||
214 | elsif Nkind (Opnd) = N_Slice then | |
215 | Opnd_Type := Etype (Opnd); | |
216 | end if; | |
217 | end Set_Assignment_Type; | |
218 | ||
219 | -- Start of processing for Analyze_Assignment | |
220 | ||
221 | begin | |
222 | Analyze (Rhs); | |
223 | Analyze (Lhs); | |
224 | T1 := Etype (Lhs); | |
225 | ||
226 | -- In the most general case, both Lhs and Rhs can be overloaded, and we | |
227 | -- must compute the intersection of the possible types on each side. | |
228 | ||
229 | if Is_Overloaded (Lhs) then | |
230 | declare | |
231 | I : Interp_Index; | |
232 | It : Interp; | |
233 | ||
234 | begin | |
235 | T1 := Any_Type; | |
236 | Get_First_Interp (Lhs, I, It); | |
237 | ||
238 | while Present (It.Typ) loop | |
239 | if Has_Compatible_Type (Rhs, It.Typ) then | |
996ae0b0 RK |
240 | if T1 /= Any_Type then |
241 | ||
242 | -- An explicit dereference is overloaded if the prefix | |
243 | -- is. Try to remove the ambiguity on the prefix, the | |
244 | -- error will be posted there if the ambiguity is real. | |
245 | ||
246 | if Nkind (Lhs) = N_Explicit_Dereference then | |
247 | declare | |
248 | PI : Interp_Index; | |
249 | PI1 : Interp_Index := 0; | |
250 | PIt : Interp; | |
251 | Found : Boolean; | |
252 | ||
253 | begin | |
254 | Found := False; | |
255 | Get_First_Interp (Prefix (Lhs), PI, PIt); | |
256 | ||
257 | while Present (PIt.Typ) loop | |
fbf5a39b AC |
258 | if Is_Access_Type (PIt.Typ) |
259 | and then Has_Compatible_Type | |
260 | (Rhs, Designated_Type (PIt.Typ)) | |
996ae0b0 RK |
261 | then |
262 | if Found then | |
263 | PIt := | |
264 | Disambiguate (Prefix (Lhs), | |
265 | PI1, PI, Any_Type); | |
266 | ||
267 | if PIt = No_Interp then | |
fbf5a39b AC |
268 | Error_Msg_N |
269 | ("ambiguous left-hand side" | |
270 | & " in assignment", Lhs); | |
271 | exit; | |
996ae0b0 RK |
272 | else |
273 | Resolve (Prefix (Lhs), PIt.Typ); | |
274 | end if; | |
275 | ||
276 | exit; | |
277 | else | |
278 | Found := True; | |
279 | PI1 := PI; | |
280 | end if; | |
281 | end if; | |
282 | ||
283 | Get_Next_Interp (PI, PIt); | |
284 | end loop; | |
285 | end; | |
286 | ||
287 | else | |
288 | Error_Msg_N | |
289 | ("ambiguous left-hand side in assignment", Lhs); | |
290 | exit; | |
291 | end if; | |
292 | else | |
293 | T1 := It.Typ; | |
294 | end if; | |
295 | end if; | |
296 | ||
297 | Get_Next_Interp (I, It); | |
298 | end loop; | |
299 | end; | |
300 | ||
301 | if T1 = Any_Type then | |
302 | Error_Msg_N | |
303 | ("no valid types for left-hand side for assignment", Lhs); | |
304 | return; | |
305 | end if; | |
306 | end if; | |
307 | ||
308 | Resolve (Lhs, T1); | |
309 | ||
310 | if not Is_Variable (Lhs) then | |
311 | Diagnose_Non_Variable_Lhs (Lhs); | |
312 | return; | |
313 | ||
314 | elsif Is_Limited_Type (T1) | |
315 | and then not Assignment_OK (Lhs) | |
316 | and then not Assignment_OK (Original_Node (Lhs)) | |
317 | then | |
318 | Error_Msg_N | |
319 | ("left hand of assignment must not be limited type", Lhs); | |
fbf5a39b | 320 | Explain_Limited_Type (T1, Lhs); |
996ae0b0 RK |
321 | return; |
322 | end if; | |
323 | ||
324 | -- Resolution may have updated the subtype, in case the left-hand | |
325 | -- side is a private protected component. Use the correct subtype | |
326 | -- to avoid scoping issues in the back-end. | |
327 | ||
328 | T1 := Etype (Lhs); | |
329 | Set_Assignment_Type (Lhs, T1); | |
330 | ||
331 | Resolve (Rhs, T1); | |
332 | ||
fbf5a39b | 333 | -- Remaining steps are skipped if Rhs was syntactically in error |
996ae0b0 RK |
334 | |
335 | if Rhs = Error then | |
336 | return; | |
337 | end if; | |
338 | ||
339 | T2 := Etype (Rhs); | |
340 | Check_Unset_Reference (Rhs); | |
996ae0b0 RK |
341 | |
342 | if Covers (T1, T2) then | |
343 | null; | |
344 | else | |
345 | Wrong_Type (Rhs, Etype (Lhs)); | |
346 | return; | |
347 | end if; | |
348 | ||
349 | Set_Assignment_Type (Rhs, T2); | |
350 | ||
fbf5a39b AC |
351 | if Total_Errors_Detected /= 0 then |
352 | if No (T1) then | |
353 | T1 := Any_Type; | |
354 | end if; | |
355 | ||
356 | if No (T2) then | |
357 | T2 := Any_Type; | |
358 | end if; | |
359 | end if; | |
360 | ||
996ae0b0 RK |
361 | if T1 = Any_Type or else T2 = Any_Type then |
362 | return; | |
363 | end if; | |
364 | ||
365 | if (Is_Class_Wide_Type (T2) or else Is_Dynamically_Tagged (Rhs)) | |
366 | and then not Is_Class_Wide_Type (T1) | |
367 | then | |
368 | Error_Msg_N ("dynamically tagged expression not allowed!", Rhs); | |
369 | ||
370 | elsif Is_Class_Wide_Type (T1) | |
371 | and then not Is_Class_Wide_Type (T2) | |
372 | and then not Is_Tag_Indeterminate (Rhs) | |
373 | and then not Is_Dynamically_Tagged (Rhs) | |
374 | then | |
375 | Error_Msg_N ("dynamically tagged expression required!", Rhs); | |
376 | end if; | |
377 | ||
378 | -- Tag propagation is done only in semantics mode only. If expansion | |
379 | -- is on, the rhs tag indeterminate function call has been expanded | |
380 | -- and tag propagation would have happened too late, so the | |
381 | -- propagation take place in expand_call instead. | |
382 | ||
383 | if not Expander_Active | |
384 | and then Is_Class_Wide_Type (T1) | |
385 | and then Is_Tag_Indeterminate (Rhs) | |
386 | then | |
387 | Propagate_Tag (Lhs, Rhs); | |
388 | end if; | |
389 | ||
390 | if Is_Scalar_Type (T1) then | |
391 | Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); | |
392 | ||
fbf5a39b AC |
393 | elsif Is_Array_Type (T1) |
394 | and then | |
395 | (Nkind (Rhs) /= N_Type_Conversion | |
396 | or else Is_Constrained (Etype (Rhs))) | |
397 | then | |
996ae0b0 RK |
398 | |
399 | -- Assignment verifies that the length of the Lsh and Rhs are equal, | |
fbf5a39b AC |
400 | -- but of course the indices do not have to match. If the right-hand |
401 | -- side is a type conversion to an unconstrained type, a length check | |
402 | -- is performed on the expression itself during expansion. In rare | |
403 | -- cases, the redundant length check is computed on an index type | |
404 | -- with a different representation, triggering incorrect code in | |
405 | -- the back end. | |
996ae0b0 RK |
406 | |
407 | Apply_Length_Check (Rhs, Etype (Lhs)); | |
408 | ||
409 | else | |
410 | -- Discriminant checks are applied in the course of expansion. | |
411 | null; | |
412 | end if; | |
413 | ||
414 | -- ??? a real accessibility check is needed when ??? | |
415 | ||
416 | -- Post warning for useless assignment | |
417 | ||
418 | if Warn_On_Redundant_Constructs | |
419 | ||
420 | -- We only warn for source constructs | |
421 | ||
422 | and then Comes_From_Source (N) | |
423 | ||
424 | -- Where the entity is the same on both sides | |
425 | ||
426 | and then Is_Entity_Name (Lhs) | |
fbf5a39b AC |
427 | and then Is_Entity_Name (Original_Node (Rhs)) |
428 | and then Entity (Lhs) = Entity (Original_Node (Rhs)) | |
996ae0b0 RK |
429 | |
430 | -- But exclude the case where the right side was an operation | |
431 | -- that got rewritten (e.g. JUNK + K, where K was known to be | |
432 | -- zero). We don't want to warn in such a case, since it is | |
433 | -- reasonable to write such expressions especially when K is | |
434 | -- defined symbolically in some other package. | |
435 | ||
436 | and then Nkind (Original_Node (Rhs)) not in N_Op | |
437 | then | |
438 | Error_Msg_NE | |
439 | ("?useless assignment of & to itself", N, Entity (Lhs)); | |
440 | end if; | |
fbf5a39b AC |
441 | |
442 | Note_Possible_Modification (Lhs); | |
443 | ||
444 | -- Check for non-allowed composite assignment | |
445 | ||
446 | if not Support_Composite_Assign_On_Target | |
447 | and then (Is_Array_Type (T1) or else Is_Record_Type (T1)) | |
448 | and then (not Has_Size_Clause (T1) or else Esize (T1) > 64) | |
449 | then | |
450 | Error_Msg_CRT ("composite assignment", N); | |
451 | end if; | |
452 | ||
453 | -- One more step. Let's see if we have a simple assignment of a | |
454 | -- known at compile time value to a simple variable. If so, we | |
455 | -- can record the value as the current value providing that: | |
456 | ||
457 | -- We still have a simple assignment statement (no expansion | |
458 | -- activity has modified it in some peculiar manner) | |
459 | ||
460 | -- The type is a discrete type | |
461 | ||
462 | -- The assignment is to a named entity | |
463 | ||
464 | -- The value is known at compile time | |
465 | ||
466 | if Nkind (N) /= N_Assignment_Statement | |
467 | or else not Is_Discrete_Type (T1) | |
468 | or else not Is_Entity_Name (Lhs) | |
469 | or else not Compile_Time_Known_Value (Rhs) | |
470 | then | |
471 | return; | |
472 | end if; | |
473 | ||
474 | Ent := Entity (Lhs); | |
475 | ||
476 | -- Capture value if save to do so | |
477 | ||
478 | if Safe_To_Capture_Value (N, Ent) then | |
479 | Set_Current_Value (Ent, Rhs); | |
480 | end if; | |
996ae0b0 RK |
481 | end Analyze_Assignment; |
482 | ||
483 | ----------------------------- | |
484 | -- Analyze_Block_Statement -- | |
485 | ----------------------------- | |
486 | ||
487 | procedure Analyze_Block_Statement (N : Node_Id) is | |
488 | Decls : constant List_Id := Declarations (N); | |
489 | Id : constant Node_Id := Identifier (N); | |
fbf5a39b | 490 | Ent : Entity_Id := Empty; |
996ae0b0 RK |
491 | |
492 | begin | |
493 | -- If a label is present analyze it and mark it as referenced | |
494 | ||
495 | if Present (Id) then | |
496 | Analyze (Id); | |
497 | Ent := Entity (Id); | |
996ae0b0 | 498 | |
fbf5a39b AC |
499 | -- An error defense. If we have an identifier, but no entity, then |
500 | -- something is wrong. If we have previous errors, then just remove | |
501 | -- the identifier and continue, otherwise raise an exception. | |
502 | ||
503 | if No (Ent) then | |
504 | if Total_Errors_Detected /= 0 then | |
505 | Set_Identifier (N, Empty); | |
506 | else | |
507 | raise Program_Error; | |
508 | end if; | |
509 | ||
510 | else | |
511 | Set_Ekind (Ent, E_Block); | |
512 | Generate_Reference (Ent, N, ' '); | |
513 | Generate_Definition (Ent); | |
514 | ||
515 | if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then | |
516 | Set_Label_Construct (Parent (Ent), N); | |
517 | end if; | |
996ae0b0 | 518 | end if; |
fbf5a39b | 519 | end if; |
996ae0b0 | 520 | |
fbf5a39b | 521 | -- If no entity set, create a label entity |
996ae0b0 | 522 | |
fbf5a39b | 523 | if No (Ent) then |
996ae0b0 RK |
524 | Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); |
525 | Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N))); | |
fbf5a39b | 526 | Set_Parent (Ent, N); |
996ae0b0 RK |
527 | end if; |
528 | ||
529 | Set_Etype (Ent, Standard_Void_Type); | |
57568d91 | 530 | Set_Block_Node (Ent, Identifier (N)); |
996ae0b0 RK |
531 | New_Scope (Ent); |
532 | ||
533 | if Present (Decls) then | |
534 | Analyze_Declarations (Decls); | |
535 | Check_Completion; | |
536 | end if; | |
537 | ||
538 | Analyze (Handled_Statement_Sequence (N)); | |
07fc65c4 | 539 | Process_End_Label (Handled_Statement_Sequence (N), 'e', Ent); |
996ae0b0 RK |
540 | |
541 | -- Analyze exception handlers if present. Note that the test for | |
542 | -- HSS being present is an error defence against previous errors. | |
543 | ||
544 | if Present (Handled_Statement_Sequence (N)) | |
545 | and then Present (Exception_Handlers (Handled_Statement_Sequence (N))) | |
546 | then | |
547 | declare | |
548 | S : Entity_Id := Scope (Ent); | |
549 | ||
550 | begin | |
551 | -- Indicate that enclosing scopes contain a block with handlers. | |
552 | -- Only non-generic scopes need to be marked. | |
553 | ||
554 | loop | |
555 | Set_Has_Nested_Block_With_Handler (S); | |
556 | exit when Is_Overloadable (S) | |
557 | or else Ekind (S) = E_Package | |
fbf5a39b | 558 | or else Is_Generic_Unit (S); |
996ae0b0 RK |
559 | S := Scope (S); |
560 | end loop; | |
561 | end; | |
562 | end if; | |
563 | ||
564 | Check_References (Ent); | |
565 | End_Scope; | |
566 | end Analyze_Block_Statement; | |
567 | ||
568 | ---------------------------- | |
569 | -- Analyze_Case_Statement -- | |
570 | ---------------------------- | |
571 | ||
572 | procedure Analyze_Case_Statement (N : Node_Id) is | |
573 | ||
574 | Statements_Analyzed : Boolean := False; | |
575 | -- Set True if at least some statement sequences get analyzed. | |
576 | -- If False on exit, means we had a serious error that prevented | |
577 | -- full analysis of the case statement, and as a result it is not | |
578 | -- a good idea to output warning messages about unreachable code. | |
579 | ||
580 | Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; | |
581 | -- Recursively save value of this global, will be restored on exit | |
582 | ||
583 | procedure Non_Static_Choice_Error (Choice : Node_Id); | |
584 | -- Error routine invoked by the generic instantiation below when | |
fbf5a39b | 585 | -- the case statment has a non static choice. |
996ae0b0 RK |
586 | |
587 | procedure Process_Statements (Alternative : Node_Id); | |
588 | -- Analyzes all the statements associated to a case alternative. | |
589 | -- Needed by the generic instantiation below. | |
590 | ||
591 | package Case_Choices_Processing is new | |
592 | Generic_Choices_Processing | |
593 | (Get_Alternatives => Alternatives, | |
594 | Get_Choices => Discrete_Choices, | |
595 | Process_Empty_Choice => No_OP, | |
596 | Process_Non_Static_Choice => Non_Static_Choice_Error, | |
597 | Process_Associated_Node => Process_Statements); | |
598 | use Case_Choices_Processing; | |
599 | -- Instantiation of the generic choice processing package. | |
600 | ||
601 | ----------------------------- | |
602 | -- Non_Static_Choice_Error -- | |
603 | ----------------------------- | |
604 | ||
605 | procedure Non_Static_Choice_Error (Choice : Node_Id) is | |
606 | begin | |
fbf5a39b AC |
607 | Flag_Non_Static_Expr |
608 | ("choice given in case statement is not static!", Choice); | |
996ae0b0 RK |
609 | end Non_Static_Choice_Error; |
610 | ||
611 | ------------------------ | |
612 | -- Process_Statements -- | |
613 | ------------------------ | |
614 | ||
615 | procedure Process_Statements (Alternative : Node_Id) is | |
616 | begin | |
617 | Unblocked_Exit_Count := Unblocked_Exit_Count + 1; | |
618 | Statements_Analyzed := True; | |
619 | Analyze_Statements (Statements (Alternative)); | |
620 | end Process_Statements; | |
621 | ||
622 | -- Variables local to Analyze_Case_Statement. | |
623 | ||
624 | Exp : Node_Id; | |
625 | Exp_Type : Entity_Id; | |
626 | Exp_Btype : Entity_Id; | |
627 | ||
628 | Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); | |
629 | Last_Choice : Nat; | |
630 | Dont_Care : Boolean; | |
631 | Others_Present : Boolean; | |
632 | ||
633 | -- Start of processing for Analyze_Case_Statement | |
634 | ||
635 | begin | |
636 | Unblocked_Exit_Count := 0; | |
637 | Exp := Expression (N); | |
638 | Analyze_And_Resolve (Exp, Any_Discrete); | |
639 | Check_Unset_Reference (Exp); | |
640 | Exp_Type := Etype (Exp); | |
641 | Exp_Btype := Base_Type (Exp_Type); | |
642 | ||
643 | -- The expression must be of a discrete type which must be determinable | |
644 | -- independently of the context in which the expression occurs, but | |
645 | -- using the fact that the expression must be of a discrete type. | |
646 | -- Moreover, the type this expression must not be a character literal | |
647 | -- (which is always ambiguous) or, for Ada-83, a generic formal type. | |
648 | ||
649 | -- If error already reported by Resolve, nothing more to do | |
650 | ||
651 | if Exp_Btype = Any_Discrete | |
652 | or else Exp_Btype = Any_Type | |
653 | then | |
654 | return; | |
655 | ||
656 | elsif Exp_Btype = Any_Character then | |
657 | Error_Msg_N | |
658 | ("character literal as case expression is ambiguous", Exp); | |
659 | return; | |
660 | ||
661 | elsif Ada_83 | |
662 | and then (Is_Generic_Type (Exp_Btype) | |
663 | or else Is_Generic_Type (Root_Type (Exp_Btype))) | |
664 | then | |
665 | Error_Msg_N | |
666 | ("(Ada 83) case expression cannot be of a generic type", Exp); | |
667 | return; | |
668 | end if; | |
669 | ||
670 | -- If the case expression is a formal object of mode in out, | |
671 | -- then treat it as having a nonstatic subtype by forcing | |
672 | -- use of the base type (which has to get passed to | |
673 | -- Check_Case_Choices below). Also use base type when | |
674 | -- the case expression is parenthesized. | |
675 | ||
676 | if Paren_Count (Exp) > 0 | |
677 | or else (Is_Entity_Name (Exp) | |
678 | and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter) | |
679 | then | |
680 | Exp_Type := Exp_Btype; | |
681 | end if; | |
682 | ||
683 | -- Call the instantiated Analyze_Choices which does the rest of the work | |
684 | ||
685 | Analyze_Choices | |
686 | (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); | |
687 | ||
688 | if Exp_Type = Universal_Integer and then not Others_Present then | |
689 | Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); | |
690 | end if; | |
691 | ||
692 | -- If all our exits were blocked by unconditional transfers of control, | |
693 | -- then the entire CASE statement acts as an unconditional transfer of | |
694 | -- control, so treat it like one, and check unreachable code. Skip this | |
695 | -- test if we had serious errors preventing any statement analysis. | |
696 | ||
697 | if Unblocked_Exit_Count = 0 and then Statements_Analyzed then | |
698 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
699 | Check_Unreachable_Code (N); | |
700 | else | |
701 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
702 | end if; | |
fbf5a39b AC |
703 | |
704 | if not Expander_Active | |
705 | and then Compile_Time_Known_Value (Expression (N)) | |
706 | and then Serious_Errors_Detected = 0 | |
707 | then | |
708 | declare | |
709 | Chosen : Node_Id := Find_Static_Alternative (N); | |
710 | Alt : Node_Id; | |
711 | ||
712 | begin | |
713 | Alt := First (Alternatives (N)); | |
714 | ||
715 | while Present (Alt) loop | |
716 | if Alt /= Chosen then | |
717 | Remove_Warning_Messages (Statements (Alt)); | |
718 | end if; | |
719 | ||
720 | Next (Alt); | |
721 | end loop; | |
722 | end; | |
723 | end if; | |
996ae0b0 RK |
724 | end Analyze_Case_Statement; |
725 | ||
726 | ---------------------------- | |
727 | -- Analyze_Exit_Statement -- | |
728 | ---------------------------- | |
729 | ||
730 | -- If the exit includes a name, it must be the name of a currently open | |
731 | -- loop. Otherwise there must be an innermost open loop on the stack, | |
732 | -- to which the statement implicitly refers. | |
733 | ||
734 | procedure Analyze_Exit_Statement (N : Node_Id) is | |
735 | Target : constant Node_Id := Name (N); | |
736 | Cond : constant Node_Id := Condition (N); | |
737 | Scope_Id : Entity_Id; | |
738 | U_Name : Entity_Id; | |
739 | Kind : Entity_Kind; | |
740 | ||
741 | begin | |
742 | if No (Cond) then | |
743 | Check_Unreachable_Code (N); | |
744 | end if; | |
745 | ||
746 | if Present (Target) then | |
747 | Analyze (Target); | |
748 | U_Name := Entity (Target); | |
749 | ||
750 | if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then | |
751 | Error_Msg_N ("invalid loop name in exit statement", N); | |
752 | return; | |
753 | else | |
754 | Set_Has_Exit (U_Name); | |
755 | end if; | |
756 | ||
757 | else | |
758 | U_Name := Empty; | |
759 | end if; | |
760 | ||
761 | for J in reverse 0 .. Scope_Stack.Last loop | |
762 | Scope_Id := Scope_Stack.Table (J).Entity; | |
763 | Kind := Ekind (Scope_Id); | |
764 | ||
765 | if Kind = E_Loop | |
766 | and then (No (Target) or else Scope_Id = U_Name) then | |
767 | Set_Has_Exit (Scope_Id); | |
768 | exit; | |
769 | ||
770 | elsif Kind = E_Block or else Kind = E_Loop then | |
771 | null; | |
772 | ||
773 | else | |
774 | Error_Msg_N | |
775 | ("cannot exit from program unit or accept statement", N); | |
776 | exit; | |
777 | end if; | |
778 | end loop; | |
779 | ||
780 | -- Verify that if present the condition is a Boolean expression. | |
781 | ||
782 | if Present (Cond) then | |
783 | Analyze_And_Resolve (Cond, Any_Boolean); | |
784 | Check_Unset_Reference (Cond); | |
785 | end if; | |
786 | end Analyze_Exit_Statement; | |
787 | ||
788 | ---------------------------- | |
789 | -- Analyze_Goto_Statement -- | |
790 | ---------------------------- | |
791 | ||
792 | procedure Analyze_Goto_Statement (N : Node_Id) is | |
793 | Label : constant Node_Id := Name (N); | |
794 | Scope_Id : Entity_Id; | |
795 | Label_Scope : Entity_Id; | |
796 | ||
797 | begin | |
798 | Check_Unreachable_Code (N); | |
799 | ||
800 | Analyze (Label); | |
801 | ||
802 | if Entity (Label) = Any_Id then | |
803 | return; | |
804 | ||
805 | elsif Ekind (Entity (Label)) /= E_Label then | |
806 | Error_Msg_N ("target of goto statement must be a label", Label); | |
807 | return; | |
808 | ||
809 | elsif not Reachable (Entity (Label)) then | |
810 | Error_Msg_N ("target of goto statement is not reachable", Label); | |
811 | return; | |
812 | end if; | |
813 | ||
814 | Label_Scope := Enclosing_Scope (Entity (Label)); | |
815 | ||
816 | for J in reverse 0 .. Scope_Stack.Last loop | |
817 | Scope_Id := Scope_Stack.Table (J).Entity; | |
818 | ||
819 | if Label_Scope = Scope_Id | |
820 | or else (Ekind (Scope_Id) /= E_Block | |
821 | and then Ekind (Scope_Id) /= E_Loop) | |
822 | then | |
823 | if Scope_Id /= Label_Scope then | |
824 | Error_Msg_N | |
825 | ("cannot exit from program unit or accept statement", N); | |
826 | end if; | |
827 | ||
828 | return; | |
829 | end if; | |
830 | end loop; | |
831 | ||
832 | raise Program_Error; | |
996ae0b0 RK |
833 | end Analyze_Goto_Statement; |
834 | ||
835 | -------------------------- | |
836 | -- Analyze_If_Statement -- | |
837 | -------------------------- | |
838 | ||
839 | -- A special complication arises in the analysis of if statements. | |
fbf5a39b AC |
840 | |
841 | -- The expander has circuitry to completely delete code that it | |
996ae0b0 RK |
842 | -- can tell will not be executed (as a result of compile time known |
843 | -- conditions). In the analyzer, we ensure that code that will be | |
844 | -- deleted in this manner is analyzed but not expanded. This is | |
845 | -- obviously more efficient, but more significantly, difficulties | |
846 | -- arise if code is expanded and then eliminated (e.g. exception | |
fbf5a39b AC |
847 | -- table entries disappear). Similarly, itypes generated in deleted |
848 | -- code must be frozen from start, because the nodes on which they | |
849 | -- depend will not be available at the freeze point. | |
996ae0b0 RK |
850 | |
851 | procedure Analyze_If_Statement (N : Node_Id) is | |
852 | E : Node_Id; | |
853 | ||
854 | Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; | |
855 | -- Recursively save value of this global, will be restored on exit | |
856 | ||
fbf5a39b AC |
857 | Save_In_Deleted_Code : Boolean; |
858 | ||
996ae0b0 RK |
859 | Del : Boolean := False; |
860 | -- This flag gets set True if a True condition has been found, | |
861 | -- which means that remaining ELSE/ELSIF parts are deleted. | |
862 | ||
863 | procedure Analyze_Cond_Then (Cnode : Node_Id); | |
864 | -- This is applied to either the N_If_Statement node itself or | |
865 | -- to an N_Elsif_Part node. It deals with analyzing the condition | |
866 | -- and the THEN statements associated with it. | |
867 | ||
fbf5a39b AC |
868 | ----------------------- |
869 | -- Analyze_Cond_Then -- | |
870 | ----------------------- | |
871 | ||
996ae0b0 RK |
872 | procedure Analyze_Cond_Then (Cnode : Node_Id) is |
873 | Cond : constant Node_Id := Condition (Cnode); | |
874 | Tstm : constant List_Id := Then_Statements (Cnode); | |
875 | ||
876 | begin | |
877 | Unblocked_Exit_Count := Unblocked_Exit_Count + 1; | |
878 | Analyze_And_Resolve (Cond, Any_Boolean); | |
879 | Check_Unset_Reference (Cond); | |
fbf5a39b | 880 | Check_Possible_Current_Value_Condition (Cnode); |
996ae0b0 RK |
881 | |
882 | -- If already deleting, then just analyze then statements | |
883 | ||
884 | if Del then | |
885 | Analyze_Statements (Tstm); | |
886 | ||
887 | -- Compile time known value, not deleting yet | |
888 | ||
889 | elsif Compile_Time_Known_Value (Cond) then | |
fbf5a39b | 890 | Save_In_Deleted_Code := In_Deleted_Code; |
996ae0b0 RK |
891 | |
892 | -- If condition is True, then analyze the THEN statements | |
893 | -- and set no expansion for ELSE and ELSIF parts. | |
894 | ||
895 | if Is_True (Expr_Value (Cond)) then | |
896 | Analyze_Statements (Tstm); | |
897 | Del := True; | |
898 | Expander_Mode_Save_And_Set (False); | |
fbf5a39b | 899 | In_Deleted_Code := True; |
996ae0b0 RK |
900 | |
901 | -- If condition is False, analyze THEN with expansion off | |
902 | ||
903 | else -- Is_False (Expr_Value (Cond)) | |
904 | Expander_Mode_Save_And_Set (False); | |
fbf5a39b | 905 | In_Deleted_Code := True; |
996ae0b0 RK |
906 | Analyze_Statements (Tstm); |
907 | Expander_Mode_Restore; | |
fbf5a39b | 908 | In_Deleted_Code := Save_In_Deleted_Code; |
996ae0b0 RK |
909 | end if; |
910 | ||
911 | -- Not known at compile time, not deleting, normal analysis | |
912 | ||
913 | else | |
914 | Analyze_Statements (Tstm); | |
915 | end if; | |
916 | end Analyze_Cond_Then; | |
917 | ||
918 | -- Start of Analyze_If_Statement | |
919 | ||
920 | begin | |
921 | -- Initialize exit count for else statements. If there is no else | |
922 | -- part, this count will stay non-zero reflecting the fact that the | |
923 | -- uncovered else case is an unblocked exit. | |
924 | ||
925 | Unblocked_Exit_Count := 1; | |
926 | Analyze_Cond_Then (N); | |
927 | ||
928 | -- Now to analyze the elsif parts if any are present | |
929 | ||
930 | if Present (Elsif_Parts (N)) then | |
931 | E := First (Elsif_Parts (N)); | |
932 | while Present (E) loop | |
933 | Analyze_Cond_Then (E); | |
934 | Next (E); | |
935 | end loop; | |
936 | end if; | |
937 | ||
938 | if Present (Else_Statements (N)) then | |
939 | Analyze_Statements (Else_Statements (N)); | |
940 | end if; | |
941 | ||
942 | -- If all our exits were blocked by unconditional transfers of control, | |
943 | -- then the entire IF statement acts as an unconditional transfer of | |
944 | -- control, so treat it like one, and check unreachable code. | |
945 | ||
946 | if Unblocked_Exit_Count = 0 then | |
947 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
948 | Check_Unreachable_Code (N); | |
949 | else | |
950 | Unblocked_Exit_Count := Save_Unblocked_Exit_Count; | |
951 | end if; | |
952 | ||
953 | if Del then | |
954 | Expander_Mode_Restore; | |
fbf5a39b | 955 | In_Deleted_Code := Save_In_Deleted_Code; |
996ae0b0 RK |
956 | end if; |
957 | ||
fbf5a39b AC |
958 | if not Expander_Active |
959 | and then Compile_Time_Known_Value (Condition (N)) | |
960 | and then Serious_Errors_Detected = 0 | |
961 | then | |
962 | if Is_True (Expr_Value (Condition (N))) then | |
963 | Remove_Warning_Messages (Else_Statements (N)); | |
964 | ||
965 | if Present (Elsif_Parts (N)) then | |
966 | E := First (Elsif_Parts (N)); | |
967 | ||
968 | while Present (E) loop | |
969 | Remove_Warning_Messages (Then_Statements (E)); | |
970 | Next (E); | |
971 | end loop; | |
972 | end if; | |
973 | ||
974 | else | |
975 | Remove_Warning_Messages (Then_Statements (N)); | |
976 | end if; | |
977 | end if; | |
996ae0b0 RK |
978 | end Analyze_If_Statement; |
979 | ||
980 | ---------------------------------------- | |
981 | -- Analyze_Implicit_Label_Declaration -- | |
982 | ---------------------------------------- | |
983 | ||
984 | -- An implicit label declaration is generated in the innermost | |
985 | -- enclosing declarative part. This is done for labels as well as | |
986 | -- block and loop names. | |
987 | ||
988 | -- Note: any changes in this routine may need to be reflected in | |
989 | -- Analyze_Label_Entity. | |
990 | ||
991 | procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is | |
fbf5a39b | 992 | Id : constant Node_Id := Defining_Identifier (N); |
996ae0b0 RK |
993 | |
994 | begin | |
fbf5a39b | 995 | Enter_Name (Id); |
996ae0b0 RK |
996 | Set_Ekind (Id, E_Label); |
997 | Set_Etype (Id, Standard_Void_Type); | |
998 | Set_Enclosing_Scope (Id, Current_Scope); | |
999 | end Analyze_Implicit_Label_Declaration; | |
1000 | ||
1001 | ------------------------------ | |
1002 | -- Analyze_Iteration_Scheme -- | |
1003 | ------------------------------ | |
1004 | ||
1005 | procedure Analyze_Iteration_Scheme (N : Node_Id) is | |
1006 | begin | |
1007 | -- For an infinite loop, there is no iteration scheme | |
1008 | ||
1009 | if No (N) then | |
1010 | return; | |
1011 | ||
1012 | else | |
1013 | declare | |
1014 | Cond : constant Node_Id := Condition (N); | |
1015 | ||
1016 | begin | |
1017 | -- For WHILE loop, verify that the condition is a Boolean | |
1018 | -- expression and resolve and check it. | |
1019 | ||
1020 | if Present (Cond) then | |
1021 | Analyze_And_Resolve (Cond, Any_Boolean); | |
1022 | Check_Unset_Reference (Cond); | |
1023 | ||
1024 | -- Else we have a FOR loop | |
1025 | ||
1026 | else | |
1027 | declare | |
1028 | LP : constant Node_Id := Loop_Parameter_Specification (N); | |
1029 | Id : constant Entity_Id := Defining_Identifier (LP); | |
1030 | DS : constant Node_Id := Discrete_Subtype_Definition (LP); | |
996ae0b0 RK |
1031 | |
1032 | begin | |
1033 | Enter_Name (Id); | |
1034 | ||
1035 | -- We always consider the loop variable to be referenced, | |
1036 | -- since the loop may be used just for counting purposes. | |
1037 | ||
1038 | Generate_Reference (Id, N, ' '); | |
1039 | ||
1040 | -- Check for case of loop variable hiding a local | |
1041 | -- variable (used later on to give a nice warning | |
1042 | -- if the hidden variable is never assigned). | |
1043 | ||
1044 | declare | |
1045 | H : constant Entity_Id := Homonym (Id); | |
1046 | ||
1047 | begin | |
1048 | if Present (H) | |
1049 | and then Enclosing_Dynamic_Scope (H) = | |
1050 | Enclosing_Dynamic_Scope (Id) | |
1051 | and then Ekind (H) = E_Variable | |
1052 | and then Is_Discrete_Type (Etype (H)) | |
1053 | then | |
1054 | Set_Hiding_Loop_Variable (H, Id); | |
1055 | end if; | |
1056 | end; | |
1057 | ||
1058 | -- Now analyze the subtype definition | |
1059 | ||
1060 | Analyze (DS); | |
1061 | ||
1062 | if DS = Error then | |
1063 | return; | |
1064 | end if; | |
1065 | ||
1066 | -- The subtype indication may denote the completion | |
1067 | -- of an incomplete type declaration. | |
1068 | ||
1069 | if Is_Entity_Name (DS) | |
1070 | and then Present (Entity (DS)) | |
1071 | and then Is_Type (Entity (DS)) | |
1072 | and then Ekind (Entity (DS)) = E_Incomplete_Type | |
1073 | then | |
1074 | Set_Entity (DS, Get_Full_View (Entity (DS))); | |
1075 | Set_Etype (DS, Entity (DS)); | |
1076 | end if; | |
1077 | ||
1078 | if not Is_Discrete_Type (Etype (DS)) then | |
1079 | Wrong_Type (DS, Any_Discrete); | |
1080 | Set_Etype (DS, Any_Type); | |
1081 | end if; | |
1082 | ||
1083 | Make_Index (DS, LP); | |
1084 | ||
1085 | Set_Ekind (Id, E_Loop_Parameter); | |
1086 | Set_Etype (Id, Etype (DS)); | |
1087 | Set_Is_Known_Valid (Id, True); | |
1088 | ||
1089 | -- The loop is not a declarative part, so the only entity | |
fbf5a39b | 1090 | -- declared "within" must be frozen explicitly. |
996ae0b0 | 1091 | |
fbf5a39b AC |
1092 | declare |
1093 | Flist : constant List_Id := Freeze_Entity (Id, Sloc (N)); | |
1094 | begin | |
1095 | if Is_Non_Empty_List (Flist) then | |
1096 | Insert_Actions (N, Flist); | |
1097 | end if; | |
1098 | end; | |
996ae0b0 | 1099 | |
4fa964a6 RD |
1100 | -- Check for null or possibly null range and issue warning. |
1101 | -- We suppress such messages in generic templates and | |
1102 | -- instances, because in practice they tend to be dubious | |
1103 | -- in these cases. | |
996ae0b0 RK |
1104 | |
1105 | if Nkind (DS) = N_Range | |
1106 | and then Comes_From_Source (N) | |
996ae0b0 RK |
1107 | then |
1108 | declare | |
1109 | L : constant Node_Id := Low_Bound (DS); | |
1110 | H : constant Node_Id := High_Bound (DS); | |
1111 | ||
1112 | Llo : Uint; | |
1113 | Lhi : Uint; | |
1114 | LOK : Boolean; | |
1115 | Hlo : Uint; | |
1116 | Hhi : Uint; | |
1117 | HOK : Boolean; | |
1118 | ||
1119 | begin | |
1120 | Determine_Range (L, LOK, Llo, Lhi); | |
1121 | Determine_Range (H, HOK, Hlo, Hhi); | |
1122 | ||
1123 | -- If range of loop is null, issue warning | |
1124 | ||
1125 | if (LOK and HOK) and then Llo > Hhi then | |
fbf5a39b AC |
1126 | |
1127 | -- Suppress the warning if inside a generic | |
1128 | -- template or instance, since in practice | |
1129 | -- they tend to be dubious in these cases since | |
1130 | -- they can result from intended parametrization. | |
1131 | ||
1132 | if not Inside_A_Generic | |
1133 | and then not In_Instance | |
1134 | then | |
1135 | Error_Msg_N | |
1136 | ("?loop range is null, loop will not execute", | |
1137 | DS); | |
1138 | end if; | |
1139 | ||
1140 | -- Since we know the range of the loop is null, | |
1141 | -- set the appropriate flag to suppress any | |
1142 | -- warnings that would otherwise be issued in | |
1143 | -- the body of the loop that will not execute. | |
1144 | -- We do this even in the generic case, since | |
1145 | -- if it is dubious to warn on the null loop | |
1146 | -- itself, it is certainly dubious to warn for | |
1147 | -- conditions that occur inside it! | |
1148 | ||
1149 | Set_Is_Null_Loop (Parent (N)); | |
996ae0b0 RK |
1150 | |
1151 | -- The other case for a warning is a reverse loop | |
1152 | -- where the upper bound is the integer literal | |
1153 | -- zero or one, and the lower bound can be positive. | |
1154 | ||
fbf5a39b AC |
1155 | -- For example, we have |
1156 | ||
1157 | -- for J in reverse N .. 1 loop | |
1158 | ||
1159 | -- In practice, this is very likely to be a case | |
1160 | -- of reversing the bounds incorrectly in the range. | |
1161 | ||
996ae0b0 RK |
1162 | elsif Reverse_Present (LP) |
1163 | and then Nkind (H) = N_Integer_Literal | |
1164 | and then (Intval (H) = Uint_0 | |
1165 | or else | |
1166 | Intval (H) = Uint_1) | |
1167 | and then Lhi > Hhi | |
1168 | then | |
996ae0b0 | 1169 | Error_Msg_N ("?loop range may be null", DS); |
996ae0b0 RK |
1170 | end if; |
1171 | end; | |
1172 | end if; | |
1173 | end; | |
1174 | end if; | |
1175 | end; | |
1176 | end if; | |
1177 | end Analyze_Iteration_Scheme; | |
1178 | ||
1179 | ------------------- | |
1180 | -- Analyze_Label -- | |
1181 | ------------------- | |
1182 | ||
fbf5a39b AC |
1183 | -- Note: the semantic work required for analyzing labels (setting them as |
1184 | -- reachable) was done in a prepass through the statements in the block, | |
1185 | -- so that forward gotos would be properly handled. See Analyze_Statements | |
1186 | -- for further details. The only processing required here is to deal with | |
1187 | -- optimizations that depend on an assumption of sequential control flow, | |
1188 | -- since of course the occurrence of a label breaks this assumption. | |
996ae0b0 RK |
1189 | |
1190 | procedure Analyze_Label (N : Node_Id) is | |
fbf5a39b | 1191 | pragma Warnings (Off, N); |
996ae0b0 RK |
1192 | |
1193 | begin | |
fbf5a39b | 1194 | Kill_Current_Values; |
996ae0b0 RK |
1195 | end Analyze_Label; |
1196 | ||
1197 | -------------------------- | |
1198 | -- Analyze_Label_Entity -- | |
1199 | -------------------------- | |
1200 | ||
1201 | procedure Analyze_Label_Entity (E : Entity_Id) is | |
1202 | begin | |
1203 | Set_Ekind (E, E_Label); | |
1204 | Set_Etype (E, Standard_Void_Type); | |
1205 | Set_Enclosing_Scope (E, Current_Scope); | |
1206 | Set_Reachable (E, True); | |
1207 | end Analyze_Label_Entity; | |
1208 | ||
1209 | ---------------------------- | |
1210 | -- Analyze_Loop_Statement -- | |
1211 | ---------------------------- | |
1212 | ||
1213 | procedure Analyze_Loop_Statement (N : Node_Id) is | |
1214 | Id : constant Node_Id := Identifier (N); | |
1215 | Ent : Entity_Id; | |
1216 | ||
1217 | begin | |
1218 | if Present (Id) then | |
1219 | ||
1220 | -- Make name visible, e.g. for use in exit statements. Loop | |
1221 | -- labels are always considered to be referenced. | |
1222 | ||
1223 | Analyze (Id); | |
1224 | Ent := Entity (Id); | |
1225 | Generate_Reference (Ent, N, ' '); | |
1226 | Generate_Definition (Ent); | |
1227 | ||
1228 | -- If we found a label, mark its type. If not, ignore it, since it | |
1229 | -- means we have a conflicting declaration, which would already have | |
1230 | -- been diagnosed at declaration time. Set Label_Construct of the | |
1231 | -- implicit label declaration, which is not created by the parser | |
1232 | -- for generic units. | |
1233 | ||
1234 | if Ekind (Ent) = E_Label then | |
1235 | Set_Ekind (Ent, E_Loop); | |
1236 | ||
1237 | if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then | |
1238 | Set_Label_Construct (Parent (Ent), N); | |
1239 | end if; | |
1240 | end if; | |
1241 | ||
1242 | -- Case of no identifier present | |
1243 | ||
1244 | else | |
1245 | Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); | |
1246 | Set_Etype (Ent, Standard_Void_Type); | |
1247 | Set_Parent (Ent, N); | |
1248 | end if; | |
1249 | ||
fbf5a39b AC |
1250 | -- Kill current values on entry to loop, since statements in body |
1251 | -- of loop may have been executed before the loop is entered. | |
1252 | -- Similarly we kill values after the loop, since we do not know | |
1253 | -- that the body of the loop was executed. | |
1254 | ||
1255 | Kill_Current_Values; | |
996ae0b0 RK |
1256 | New_Scope (Ent); |
1257 | Analyze_Iteration_Scheme (Iteration_Scheme (N)); | |
1258 | Analyze_Statements (Statements (N)); | |
07fc65c4 | 1259 | Process_End_Label (N, 'e', Ent); |
996ae0b0 | 1260 | End_Scope; |
fbf5a39b | 1261 | Kill_Current_Values; |
996ae0b0 RK |
1262 | end Analyze_Loop_Statement; |
1263 | ||
1264 | ---------------------------- | |
1265 | -- Analyze_Null_Statement -- | |
1266 | ---------------------------- | |
1267 | ||
1268 | -- Note: the semantics of the null statement is implemented by a single | |
1269 | -- null statement, too bad everything isn't as simple as this! | |
1270 | ||
1271 | procedure Analyze_Null_Statement (N : Node_Id) is | |
07fc65c4 GB |
1272 | pragma Warnings (Off, N); |
1273 | ||
996ae0b0 RK |
1274 | begin |
1275 | null; | |
1276 | end Analyze_Null_Statement; | |
1277 | ||
1278 | ------------------------ | |
1279 | -- Analyze_Statements -- | |
1280 | ------------------------ | |
1281 | ||
1282 | procedure Analyze_Statements (L : List_Id) is | |
fbf5a39b AC |
1283 | S : Node_Id; |
1284 | Lab : Entity_Id; | |
996ae0b0 RK |
1285 | |
1286 | begin | |
1287 | -- The labels declared in the statement list are reachable from | |
1288 | -- statements in the list. We do this as a prepass so that any | |
1289 | -- goto statement will be properly flagged if its target is not | |
1290 | -- reachable. This is not required, but is nice behavior! | |
1291 | ||
1292 | S := First (L); | |
996ae0b0 RK |
1293 | while Present (S) loop |
1294 | if Nkind (S) = N_Label then | |
fbf5a39b AC |
1295 | Analyze (Identifier (S)); |
1296 | Lab := Entity (Identifier (S)); | |
1297 | ||
1298 | -- If we found a label mark it as reachable. | |
1299 | ||
1300 | if Ekind (Lab) = E_Label then | |
1301 | Generate_Definition (Lab); | |
1302 | Set_Reachable (Lab); | |
1303 | ||
1304 | if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then | |
1305 | Set_Label_Construct (Parent (Lab), S); | |
1306 | end if; | |
1307 | ||
1308 | -- If we failed to find a label, it means the implicit declaration | |
1309 | -- of the label was hidden. A for-loop parameter can do this to | |
1310 | -- a label with the same name inside the loop, since the implicit | |
1311 | -- label declaration is in the innermost enclosing body or block | |
1312 | -- statement. | |
1313 | ||
1314 | else | |
1315 | Error_Msg_Sloc := Sloc (Lab); | |
1316 | Error_Msg_N | |
1317 | ("implicit label declaration for & is hidden#", | |
1318 | Identifier (S)); | |
1319 | end if; | |
996ae0b0 RK |
1320 | end if; |
1321 | ||
1322 | Next (S); | |
1323 | end loop; | |
1324 | ||
1325 | -- Perform semantic analysis on all statements | |
1326 | ||
fbf5a39b | 1327 | Conditional_Statements_Begin; |
996ae0b0 | 1328 | |
fbf5a39b | 1329 | S := First (L); |
996ae0b0 | 1330 | while Present (S) loop |
fbf5a39b | 1331 | Analyze (S); |
996ae0b0 RK |
1332 | Next (S); |
1333 | end loop; | |
1334 | ||
fbf5a39b AC |
1335 | Conditional_Statements_End; |
1336 | ||
996ae0b0 RK |
1337 | -- Make labels unreachable. Visibility is not sufficient, because |
1338 | -- labels in one if-branch for example are not reachable from the | |
1339 | -- other branch, even though their declarations are in the enclosing | |
1340 | -- declarative part. | |
1341 | ||
1342 | S := First (L); | |
996ae0b0 RK |
1343 | while Present (S) loop |
1344 | if Nkind (S) = N_Label then | |
1345 | Set_Reachable (Entity (Identifier (S)), False); | |
1346 | end if; | |
1347 | ||
1348 | Next (S); | |
1349 | end loop; | |
1350 | end Analyze_Statements; | |
1351 | ||
fbf5a39b AC |
1352 | -------------------------------------------- |
1353 | -- Check_Possible_Current_Value_Condition -- | |
1354 | -------------------------------------------- | |
1355 | ||
1356 | procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id) is | |
1357 | Cond : Node_Id; | |
1358 | ||
1359 | begin | |
1360 | -- Loop to deal with (ignore for now) any NOT operators present | |
1361 | ||
1362 | Cond := Condition (Cnode); | |
1363 | while Nkind (Cond) = N_Op_Not loop | |
1364 | Cond := Right_Opnd (Cond); | |
1365 | end loop; | |
1366 | ||
1367 | -- Check possible relational operator | |
1368 | ||
1369 | if Nkind (Cond) = N_Op_Eq | |
1370 | or else | |
1371 | Nkind (Cond) = N_Op_Ne | |
1372 | or else | |
1373 | Nkind (Cond) = N_Op_Ge | |
1374 | or else | |
1375 | Nkind (Cond) = N_Op_Le | |
1376 | or else | |
1377 | Nkind (Cond) = N_Op_Gt | |
1378 | or else | |
1379 | Nkind (Cond) = N_Op_Lt | |
1380 | then | |
1381 | if Compile_Time_Known_Value (Right_Opnd (Cond)) | |
1382 | and then Nkind (Left_Opnd (Cond)) = N_Identifier | |
1383 | then | |
1384 | declare | |
1385 | Ent : constant Entity_Id := Entity (Left_Opnd (Cond)); | |
1386 | ||
1387 | begin | |
1388 | if Ekind (Ent) = E_Variable | |
1389 | or else | |
1390 | Ekind (Ent) = E_Constant | |
1391 | or else | |
1392 | Is_Formal (Ent) | |
1393 | or else | |
1394 | Ekind (Ent) = E_Loop_Parameter | |
1395 | then | |
1396 | -- Here we have a case where the Current_Value field | |
1397 | -- may need to be set. We set it if it is not already | |
1398 | -- set to a compile time expression value. | |
1399 | ||
1400 | -- Note that this represents a decision that one | |
1401 | -- condition blots out another previous one. That's | |
1402 | -- certainly right if they occur at the same level. | |
1403 | -- If the second one is nested, then the decision is | |
1404 | -- neither right nor wrong (it would be equally OK | |
1405 | -- to leave the outer one in place, or take the new | |
1406 | -- inner one. Really we should record both, but our | |
1407 | -- data structures are not that elaborate. | |
1408 | ||
1409 | if Nkind (Current_Value (Ent)) not in N_Subexpr then | |
1410 | Set_Current_Value (Ent, Cnode); | |
1411 | end if; | |
1412 | end if; | |
1413 | end; | |
1414 | end if; | |
1415 | end if; | |
1416 | end Check_Possible_Current_Value_Condition; | |
1417 | ||
996ae0b0 RK |
1418 | ---------------------------- |
1419 | -- Check_Unreachable_Code -- | |
1420 | ---------------------------- | |
1421 | ||
1422 | procedure Check_Unreachable_Code (N : Node_Id) is | |
1423 | Error_Loc : Source_Ptr; | |
1424 | P : Node_Id; | |
1425 | ||
1426 | begin | |
1427 | if Is_List_Member (N) | |
1428 | and then Comes_From_Source (N) | |
1429 | then | |
1430 | declare | |
1431 | Nxt : Node_Id; | |
1432 | ||
1433 | begin | |
1434 | Nxt := Original_Node (Next (N)); | |
1435 | ||
1436 | if Present (Nxt) | |
1437 | and then Comes_From_Source (Nxt) | |
1438 | and then Is_Statement (Nxt) | |
1439 | then | |
1440 | -- Special very annoying exception. If we have a return that | |
1441 | -- follows a raise, then we allow it without a warning, since | |
1442 | -- the Ada RM annoyingly requires a useless return here! | |
1443 | ||
1444 | if Nkind (Original_Node (N)) /= N_Raise_Statement | |
1445 | or else Nkind (Nxt) /= N_Return_Statement | |
1446 | then | |
1447 | -- The rather strange shenanigans with the warning message | |
1448 | -- here reflects the fact that Kill_Dead_Code is very good | |
1449 | -- at removing warnings in deleted code, and this is one | |
1450 | -- warning we would prefer NOT to have removed :-) | |
1451 | ||
1452 | Error_Loc := Sloc (Nxt); | |
1453 | ||
1454 | -- If we have unreachable code, analyze and remove the | |
1455 | -- unreachable code, since it is useless and we don't | |
1456 | -- want to generate junk warnings. | |
1457 | ||
1458 | -- We skip this step if we are not in code generation mode. | |
1459 | -- This is the one case where we remove dead code in the | |
1460 | -- semantics as opposed to the expander, and we do not want | |
1461 | -- to remove code if we are not in code generation mode, | |
1462 | -- since this messes up the ASIS trees. | |
1463 | ||
1464 | -- Note that one might react by moving the whole circuit to | |
1465 | -- exp_ch5, but then we lose the warning in -gnatc mode. | |
1466 | ||
1467 | if Operating_Mode = Generate_Code then | |
1468 | loop | |
1469 | Nxt := Next (N); | |
fbf5a39b AC |
1470 | |
1471 | -- Quit deleting when we have nothing more to delete | |
1472 | -- or if we hit a label (since someone could transfer | |
1473 | -- control to a label, so we should not delete it). | |
1474 | ||
1475 | exit when No (Nxt) or else Nkind (Nxt) = N_Label; | |
1476 | ||
1477 | -- Statement/declaration is to be deleted | |
1478 | ||
996ae0b0 RK |
1479 | Analyze (Nxt); |
1480 | Remove (Nxt); | |
1481 | Kill_Dead_Code (Nxt); | |
1482 | end loop; | |
1483 | end if; | |
1484 | ||
1485 | -- Now issue the warning | |
1486 | ||
1487 | Error_Msg ("?unreachable code", Error_Loc); | |
1488 | end if; | |
1489 | ||
1490 | -- If the unconditional transfer of control instruction is | |
1491 | -- the last statement of a sequence, then see if our parent | |
1492 | -- is an IF statement, and if so adjust the unblocked exit | |
1493 | -- count of the if statement to reflect the fact that this | |
1494 | -- branch of the if is indeed blocked by a transfer of control. | |
1495 | ||
1496 | else | |
1497 | P := Parent (N); | |
1498 | ||
1499 | if Nkind (P) = N_If_Statement then | |
1500 | null; | |
1501 | ||
1502 | elsif Nkind (P) = N_Elsif_Part then | |
1503 | P := Parent (P); | |
1504 | pragma Assert (Nkind (P) = N_If_Statement); | |
1505 | ||
1506 | elsif Nkind (P) = N_Case_Statement_Alternative then | |
1507 | P := Parent (P); | |
1508 | pragma Assert (Nkind (P) = N_Case_Statement); | |
1509 | ||
1510 | else | |
1511 | return; | |
1512 | end if; | |
1513 | ||
1514 | Unblocked_Exit_Count := Unblocked_Exit_Count - 1; | |
1515 | end if; | |
1516 | end; | |
1517 | end if; | |
1518 | end Check_Unreachable_Code; | |
1519 | ||
1520 | end Sem_Ch5; |