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