File : sem_case.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C A S E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1996-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 Atree; use Atree;
27 with Einfo; use Einfo;
28 with Errout; use Errout;
29 with Namet; use Namet;
30 with Nlists; use Nlists;
31 with Nmake; use Nmake;
32 with Opt; use Opt;
33 with Sem; use Sem;
34 with Sem_Aux; use Sem_Aux;
35 with Sem_Eval; use Sem_Eval;
36 with Sem_Res; use Sem_Res;
37 with Sem_Util; use Sem_Util;
38 with Sem_Type; use Sem_Type;
39 with Snames; use Snames;
40 with Stand; use Stand;
41 with Sinfo; use Sinfo;
42 with Tbuild; use Tbuild;
43 with Uintp; use Uintp;
44
45 with Ada.Unchecked_Deallocation;
46
47 with GNAT.Heap_Sort_G;
48
49 package body Sem_Case is
50
51 type Choice_Bounds is record
52 Lo : Node_Id;
53 Hi : Node_Id;
54 Node : Node_Id;
55 end record;
56 -- Represent one choice bounds entry with Lo and Hi values, Node points
57 -- to the choice node itself.
58
59 type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
60 -- Table type used to sort the choices present in a case statement or
61 -- record variant. The actual entries are stored in 1 .. Last, but we
62 -- have a 0 entry for use in sorting.
63
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
67
68 procedure Check_Choice_Set
69 (Choice_Table : in out Choice_Table_Type;
70 Bounds_Type : Entity_Id;
71 Subtyp : Entity_Id;
72 Others_Present : Boolean;
73 Case_Node : Node_Id);
74 -- This is the procedure which verifies that a set of case alternatives
75 -- or record variant choices has no duplicates, and covers the range
76 -- specified by Bounds_Type. Choice_Table contains the discrete choices
77 -- to check. These must start at position 1.
78 --
79 -- Furthermore Choice_Table (0) must exist. This element is used by
80 -- the sorting algorithm as a temporary. Others_Present is a flag
81 -- indicating whether or not an Others choice is present. Finally
82 -- Msg_Sloc gives the source location of the construct containing the
83 -- choices in the Choice_Table.
84 --
85 -- Bounds_Type is the type whose range must be covered by the alternatives
86 --
87 -- Subtyp is the subtype of the expression. If its bounds are non-static
88 -- the alternatives must cover its base type.
89
90 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
91 -- Given a Pos value of enumeration type Ctype, returns the name
92 -- ID of an appropriate string to be used in error message output.
93
94 procedure Expand_Others_Choice
95 (Case_Table : Choice_Table_Type;
96 Others_Choice : Node_Id;
97 Choice_Type : Entity_Id);
98 -- The case table is the table generated by a call to Check_Choices
99 -- (with just 1 .. Last_Choice entries present). Others_Choice is a
100 -- pointer to the N_Others_Choice node (this routine is only called if
101 -- an others choice is present), and Choice_Type is the discrete type
102 -- of the bounds. The effect of this call is to analyze the cases and
103 -- determine the set of values covered by others. This choice list is
104 -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
105
106 ----------------------
107 -- Check_Choice_Set --
108 ----------------------
109
110 procedure Check_Choice_Set
111 (Choice_Table : in out Choice_Table_Type;
112 Bounds_Type : Entity_Id;
113 Subtyp : Entity_Id;
114 Others_Present : Boolean;
115 Case_Node : Node_Id)
116 is
117 Predicate_Error : Boolean;
118 -- Flag to prevent cascaded errors when a static predicate is known to
119 -- be violated by one choice.
120
121 procedure Check_Against_Predicate
122 (Pred : in out Node_Id;
123 Choice : Choice_Bounds;
124 Prev_Lo : in out Uint;
125 Prev_Hi : in out Uint;
126 Error : in out Boolean);
127 -- Determine whether a choice covers legal values as defined by a static
128 -- predicate set. Pred is a static predicate range. Choice is the choice
129 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
130 -- choice that covered a predicate set. Error denotes whether the check
131 -- found an illegal intersection.
132
133 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
134 -- Post message "duplication of choice value(s) bla bla at xx". Message
135 -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
136
137 procedure Explain_Non_Static_Bound;
138 -- Called when we find a non-static bound, requiring the base type to
139 -- be covered. Provides where possible a helpful explanation of why the
140 -- bounds are non-static, since this is not always obvious.
141
142 function Lt_Choice (C1, C2 : Natural) return Boolean;
143 -- Comparison routine for comparing Choice_Table entries. Use the lower
144 -- bound of each Choice as the key.
145
146 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id);
147 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint);
148 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id);
149 procedure Missing_Choice (Value1 : Uint; Value2 : Uint);
150 -- Issue an error message indicating that there are missing choices,
151 -- followed by the image of the missing choices themselves which lie
152 -- between Value1 and Value2 inclusive.
153
154 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
155 -- Emit an error message for each non-covered static predicate set.
156 -- Prev_Hi denotes the upper bound of the last choice covering a set.
157
158 procedure Move_Choice (From : Natural; To : Natural);
159 -- Move routine for sorting the Choice_Table
160
161 package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);
162
163 -----------------------------
164 -- Check_Against_Predicate --
165 -----------------------------
166
167 procedure Check_Against_Predicate
168 (Pred : in out Node_Id;
169 Choice : Choice_Bounds;
170 Prev_Lo : in out Uint;
171 Prev_Hi : in out Uint;
172 Error : in out Boolean)
173 is
174 procedure Illegal_Range
175 (Loc : Source_Ptr;
176 Lo : Uint;
177 Hi : Uint);
178 -- Emit an error message regarding a choice that clashes with the
179 -- legal static predicate sets. Loc is the location of the choice
180 -- that introduced the illegal range. Lo .. Hi is the range.
181
182 function Inside_Range
183 (Lo : Uint;
184 Hi : Uint;
185 Val : Uint) return Boolean;
186 -- Determine whether position Val within a discrete type is within
187 -- the range Lo .. Hi inclusive.
188
189 -------------------
190 -- Illegal_Range --
191 -------------------
192
193 procedure Illegal_Range
194 (Loc : Source_Ptr;
195 Lo : Uint;
196 Hi : Uint)
197 is
198 begin
199 Error_Msg_Name_1 := Chars (Bounds_Type);
200
201 -- Single value
202
203 if Lo = Hi then
204 if Is_Integer_Type (Bounds_Type) then
205 Error_Msg_Uint_1 := Lo;
206 Error_Msg ("static predicate on % excludes value ^!", Loc);
207 else
208 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
209 Error_Msg ("static predicate on % excludes value %!", Loc);
210 end if;
211
212 -- Range
213
214 else
215 if Is_Integer_Type (Bounds_Type) then
216 Error_Msg_Uint_1 := Lo;
217 Error_Msg_Uint_2 := Hi;
218 Error_Msg
219 ("static predicate on % excludes range ^ .. ^!", Loc);
220 else
221 Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type);
222 Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type);
223 Error_Msg
224 ("static predicate on % excludes range % .. %!", Loc);
225 end if;
226 end if;
227 end Illegal_Range;
228
229 ------------------
230 -- Inside_Range --
231 ------------------
232
233 function Inside_Range
234 (Lo : Uint;
235 Hi : Uint;
236 Val : Uint) return Boolean
237 is
238 begin
239 return
240 Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
241 end Inside_Range;
242
243 -- Local variables
244
245 Choice_Hi : constant Uint := Expr_Value (Choice.Hi);
246 Choice_Lo : constant Uint := Expr_Value (Choice.Lo);
247 Loc : Source_Ptr;
248 LocN : Node_Id;
249 Next_Hi : Uint;
250 Next_Lo : Uint;
251 Pred_Hi : Uint;
252 Pred_Lo : Uint;
253
254 -- Start of processing for Check_Against_Predicate
255
256 begin
257 -- Find the proper error message location
258
259 if Present (Choice.Node) then
260 LocN := Choice.Node;
261 else
262 LocN := Case_Node;
263 end if;
264
265 Loc := Sloc (LocN);
266
267 if Present (Pred) then
268 Pred_Lo := Expr_Value (Low_Bound (Pred));
269 Pred_Hi := Expr_Value (High_Bound (Pred));
270
271 -- Previous choices managed to satisfy all static predicate sets
272
273 else
274 Illegal_Range (Loc, Choice_Lo, Choice_Hi);
275 Error := True;
276 return;
277 end if;
278
279 -- Step 1: Detect duplicate choices
280
281 if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
282 Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
283 Error := True;
284
285 elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then
286 Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
287 Error := True;
288
289 -- Step 2: Detect full coverage
290
291 -- Choice_Lo Choice_Hi
292 -- +============+
293 -- Pred_Lo Pred_Hi
294
295 elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then
296 Prev_Lo := Choice_Lo;
297 Prev_Hi := Choice_Hi;
298 Next (Pred);
299
300 -- Step 3: Detect all cases where a choice mentions values that are
301 -- not part of the static predicate sets.
302
303 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
304 -- +-----------+ . . . . . +=========+
305 -- ^ illegal ^
306
307 elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then
308 Illegal_Range (Loc, Choice_Lo, Choice_Hi);
309 Error := True;
310
311 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
312 -- +-----------+=========+===========+
313 -- ^ illegal ^
314
315 elsif Choice_Lo < Pred_Lo
316 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi)
317 then
318 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
319 Error := True;
320
321 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
322 -- +=========+ . . . . +-----------+
323 -- ^ illegal ^
324
325 elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then
326 if Others_Present then
327
328 -- Current predicate set is covered by others clause.
329
330 null;
331
332 else
333 Missing_Choice (Pred_Lo, Pred_Hi);
334 Error := True;
335 end if;
336
337 -- There may be several static predicate sets between the current
338 -- one and the choice. Inspect the next static predicate set.
339
340 Next (Pred);
341 Check_Against_Predicate
342 (Pred => Pred,
343 Choice => Choice,
344 Prev_Lo => Prev_Lo,
345 Prev_Hi => Prev_Hi,
346 Error => Error);
347
348 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
349 -- +=========+===========+-----------+
350 -- ^ illegal ^
351
352 elsif Pred_Hi < Choice_Hi
353 and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo)
354 then
355 Next (Pred);
356
357 -- The choice may fall in a static predicate set. If this is the
358 -- case, avoid mentioning legal values in the error message.
359
360 if Present (Pred) then
361 Next_Lo := Expr_Value (Low_Bound (Pred));
362 Next_Hi := Expr_Value (High_Bound (Pred));
363
364 -- The next static predicate set is to the right of the choice
365
366 if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then
367 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
368 else
369 Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1);
370 end if;
371 else
372 Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi);
373 end if;
374
375 Error := True;
376
377 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
378 -- +-----------+=========+-----------+
379 -- ^ illegal ^ ^ illegal ^
380
381 -- Emit an error on the low gap, disregard the upper gap
382
383 elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then
384 Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1);
385 Error := True;
386
387 -- Step 4: Detect all cases of partial or missing coverage
388
389 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
390 -- +=========+==========+===========+
391 -- ^ gap ^ ^ gap ^
392
393 else
394 -- An "others" choice covers all gaps
395
396 if Others_Present then
397 Prev_Lo := Choice_Lo;
398 Prev_Hi := Choice_Hi;
399
400 -- Check whether predicate set is fully covered by choice
401
402 if Pred_Hi = Choice_Hi then
403 Next (Pred);
404 end if;
405
406 -- Choice_Lo Choice_Hi Pred_Hi
407 -- +===========+===========+
408 -- Pred_Lo ^ gap ^
409
410 -- The upper gap may be covered by a subsequent choice
411
412 elsif Pred_Lo = Choice_Lo then
413 Prev_Lo := Choice_Lo;
414 Prev_Hi := Choice_Hi;
415
416 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
417 -- +===========+=========+===========+===========+
418 -- ^ covered ^ ^ gap ^
419
420 else pragma Assert (Pred_Lo < Choice_Lo);
421
422 -- A previous choice covered the gap up to the current choice
423
424 if Prev_Hi = Choice_Lo - 1 then
425 Prev_Lo := Choice_Lo;
426 Prev_Hi := Choice_Hi;
427
428 if Choice_Hi = Pred_Hi then
429 Next (Pred);
430 end if;
431
432 -- The previous choice did not intersect with the current
433 -- static predicate set.
434
435 elsif Prev_Hi < Pred_Lo then
436 Missing_Choice (Pred_Lo, Choice_Lo - 1);
437 Error := True;
438
439 -- The previous choice covered part of the static predicate set
440 -- but there is a gap after Prev_Hi.
441
442 else
443 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
444 Error := True;
445 end if;
446 end if;
447 end if;
448 end Check_Against_Predicate;
449
450 ----------------
451 -- Dup_Choice --
452 ----------------
453
454 procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is
455 begin
456 -- In some situations, we call this with a null range, and obviously
457 -- we don't want to complain in this case.
458
459 if Lo > Hi then
460 return;
461 end if;
462
463 -- Case of only one value that is duplicated
464
465 if Lo = Hi then
466
467 -- Integer type
468
469 if Is_Integer_Type (Bounds_Type) then
470
471 -- We have an integer value, Lo, but if the given choice
472 -- placement is a constant with that value, then use the
473 -- name of that constant instead in the message:
474
475 if Nkind (C) = N_Identifier
476 and then Compile_Time_Known_Value (C)
477 and then Expr_Value (C) = Lo
478 then
479 Error_Msg_N ("duplication of choice value: &#!", C);
480
481 -- Not that special case, so just output the integer value
482
483 else
484 Error_Msg_Uint_1 := Lo;
485 Error_Msg_N ("duplication of choice value: ^#!", C);
486 end if;
487
488 -- Enumeration type
489
490 else
491 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
492 Error_Msg_N ("duplication of choice value: %#!", C);
493 end if;
494
495 -- More than one choice value, so print range of values
496
497 else
498 -- Integer type
499
500 if Is_Integer_Type (Bounds_Type) then
501
502 -- Similar to the above, if C is a range of known values which
503 -- match Lo and Hi, then use the names. We have to go to the
504 -- original nodes, since the values will have been rewritten
505 -- to their integer values.
506
507 if Nkind (C) = N_Range
508 and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier
509 and then Nkind (Original_Node (High_Bound (C))) = N_Identifier
510 and then Compile_Time_Known_Value (Low_Bound (C))
511 and then Compile_Time_Known_Value (High_Bound (C))
512 and then Expr_Value (Low_Bound (C)) = Lo
513 and then Expr_Value (High_Bound (C)) = Hi
514 then
515 Error_Msg_Node_2 := Original_Node (High_Bound (C));
516 Error_Msg_N
517 ("duplication of choice values: & .. &#!",
518 Original_Node (Low_Bound (C)));
519
520 -- Not that special case, output integer values
521
522 else
523 Error_Msg_Uint_1 := Lo;
524 Error_Msg_Uint_2 := Hi;
525 Error_Msg_N ("duplication of choice values: ^ .. ^#!", C);
526 end if;
527
528 -- Enumeration type
529
530 else
531 Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
532 Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type);
533 Error_Msg_N ("duplication of choice values: % .. %#!", C);
534 end if;
535 end if;
536 end Dup_Choice;
537
538 ------------------------------
539 -- Explain_Non_Static_Bound --
540 ------------------------------
541
542 procedure Explain_Non_Static_Bound is
543 Expr : Node_Id;
544
545 begin
546 if Nkind (Case_Node) = N_Variant_Part then
547 Expr := Name (Case_Node);
548 else
549 Expr := Expression (Case_Node);
550 end if;
551
552 if Bounds_Type /= Subtyp then
553
554 -- If the case is a variant part, the expression is given by the
555 -- discriminant itself, and the bounds are the culprits.
556
557 if Nkind (Case_Node) = N_Variant_Part then
558 Error_Msg_NE
559 ("bounds of & are not static, "
560 & "alternatives must cover base type!", Expr, Expr);
561
562 -- If this is a case statement, the expression may be non-static
563 -- or else the subtype may be at fault.
564
565 elsif Is_Entity_Name (Expr) then
566 Error_Msg_NE
567 ("bounds of & are not static, "
568 & "alternatives must cover base type!", Expr, Expr);
569
570 else
571 Error_Msg_N
572 ("subtype of expression is not static, "
573 & "alternatives must cover base type!", Expr);
574 end if;
575
576 -- Otherwise the expression is not static, even if the bounds of the
577 -- type are, or else there are missing alternatives. If both, the
578 -- additional information may be redundant but harmless.
579
580 elsif not Is_Entity_Name (Expr) then
581 Error_Msg_N
582 ("subtype of expression is not static, "
583 & "alternatives must cover base type!", Expr);
584 end if;
585 end Explain_Non_Static_Bound;
586
587 ---------------
588 -- Lt_Choice --
589 ---------------
590
591 function Lt_Choice (C1, C2 : Natural) return Boolean is
592 begin
593 return
594 Expr_Value (Choice_Table (Nat (C1)).Lo)
595 <
596 Expr_Value (Choice_Table (Nat (C2)).Lo);
597 end Lt_Choice;
598
599 --------------------
600 -- Missing_Choice --
601 --------------------
602
603 procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is
604 begin
605 Missing_Choice (Expr_Value (Value1), Expr_Value (Value2));
606 end Missing_Choice;
607
608 procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is
609 begin
610 Missing_Choice (Expr_Value (Value1), Value2);
611 end Missing_Choice;
612
613 procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is
614 begin
615 Missing_Choice (Value1, Expr_Value (Value2));
616 end Missing_Choice;
617
618 --------------------
619 -- Missing_Choice --
620 --------------------
621
622 procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is
623 Msg_Sloc : constant Source_Ptr := Sloc (Case_Node);
624
625 begin
626 -- AI05-0188 : within an instance the non-others choices do not have
627 -- to belong to the actual subtype.
628
629 if Ada_Version >= Ada_2012 and then In_Instance then
630 return;
631
632 -- In some situations, we call this with a null range, and obviously
633 -- we don't want to complain in this case.
634
635 elsif Value1 > Value2 then
636 return;
637
638 -- If predicate is already known to be violated, do no check for
639 -- coverage error, to prevent cascaded messages.
640
641 elsif Predicate_Error then
642 return;
643 end if;
644
645 -- Case of only one value that is missing
646
647 if Value1 = Value2 then
648 if Is_Integer_Type (Bounds_Type) then
649 Error_Msg_Uint_1 := Value1;
650 Error_Msg ("missing case value: ^!", Msg_Sloc);
651 else
652 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
653 Error_Msg ("missing case value: %!", Msg_Sloc);
654 end if;
655
656 -- More than one choice value, so print range of values
657
658 else
659 if Is_Integer_Type (Bounds_Type) then
660 Error_Msg_Uint_1 := Value1;
661 Error_Msg_Uint_2 := Value2;
662 Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
663 else
664 Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
665 Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
666 Error_Msg ("missing case values: % .. %!", Msg_Sloc);
667 end if;
668 end if;
669 end Missing_Choice;
670
671 ---------------------
672 -- Missing_Choices --
673 ---------------------
674
675 procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is
676 Hi : Uint;
677 Lo : Uint;
678 Set : Node_Id;
679
680 begin
681 Set := Pred;
682 while Present (Set) loop
683 Lo := Expr_Value (Low_Bound (Set));
684 Hi := Expr_Value (High_Bound (Set));
685
686 -- A choice covered part of a static predicate set
687
688 if Lo <= Prev_Hi and then Prev_Hi < Hi then
689 Missing_Choice (Prev_Hi + 1, Hi);
690
691 else
692 Missing_Choice (Lo, Hi);
693 end if;
694
695 Next (Set);
696 end loop;
697 end Missing_Choices;
698
699 -----------------
700 -- Move_Choice --
701 -----------------
702
703 procedure Move_Choice (From : Natural; To : Natural) is
704 begin
705 Choice_Table (Nat (To)) := Choice_Table (Nat (From));
706 end Move_Choice;
707
708 -- Local variables
709
710 Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
711 Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
712 Num_Choices : constant Nat := Choice_Table'Last;
713 Has_Predicate : constant Boolean :=
714 Is_OK_Static_Subtype (Bounds_Type)
715 and then Has_Static_Predicate (Bounds_Type);
716
717 Choice : Node_Id;
718 Choice_Hi : Uint;
719 Choice_Lo : Uint;
720 Error : Boolean;
721 Pred : Node_Id;
722 Prev_Choice : Node_Id;
723 Prev_Lo : Uint;
724 Prev_Hi : Uint;
725
726 -- Start of processing for Check_Choice_Set
727
728 begin
729 -- If the case is part of a predicate aspect specification, do not
730 -- recheck it against itself.
731
732 if Present (Parent (Case_Node))
733 and then Nkind (Parent (Case_Node)) = N_Aspect_Specification
734 then
735 return;
736 end if;
737
738 Predicate_Error := False;
739
740 -- Choice_Table must start at 0 which is an unused location used by the
741 -- sorting algorithm. However the first valid position for a discrete
742 -- choice is 1.
743
744 pragma Assert (Choice_Table'First = 0);
745
746 -- The choices do not cover the base range. Emit an error if "others" is
747 -- not available and return as there is no need for further processing.
748
749 if Num_Choices = 0 then
750 if not Others_Present then
751 Missing_Choice (Bounds_Lo, Bounds_Hi);
752 end if;
753
754 return;
755 end if;
756
757 Sorting.Sort (Positive (Choice_Table'Last));
758
759 -- The type covered by the list of choices is actually a static subtype
760 -- subject to a static predicate. The predicate defines subsets of legal
761 -- values and requires finer grained analysis.
762
763 -- Note that in GNAT the predicate is considered static if the predicate
764 -- expression is static, independently of whether the aspect mentions
765 -- Static explicitly.
766
767 if Has_Predicate then
768 Pred := First (Static_Discrete_Predicate (Bounds_Type));
769
770 -- Make initial value smaller than 'First of type, so that first
771 -- range comparison succeeds. This applies both to integer types
772 -- and to enumeration types.
773
774 Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
775 Prev_Hi := Prev_Lo;
776
777 Error := False;
778
779 for Index in 1 .. Num_Choices loop
780 Check_Against_Predicate
781 (Pred => Pred,
782 Choice => Choice_Table (Index),
783 Prev_Lo => Prev_Lo,
784 Prev_Hi => Prev_Hi,
785 Error => Error);
786
787 -- The analysis detected an illegal intersection between a choice
788 -- and a static predicate set. Do not examine other choices unless
789 -- all errors are requested.
790
791 if Error then
792 Predicate_Error := True;
793
794 if not All_Errors_Mode then
795 return;
796 end if;
797 end if;
798 end loop;
799
800 if Predicate_Error then
801 return;
802 end if;
803
804 -- The choices may legally cover some of the static predicate sets,
805 -- but not all. Emit an error for each non-covered set.
806
807 if not Others_Present then
808 Missing_Choices (Pred, Prev_Hi);
809 end if;
810
811 -- Default analysis
812
813 else
814 Choice_Lo := Expr_Value (Choice_Table (1).Lo);
815 Choice_Hi := Expr_Value (Choice_Table (1).Hi);
816 Prev_Hi := Choice_Hi;
817
818 if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then
819 Missing_Choice (Bounds_Lo, Choice_Lo - 1);
820
821 -- If values are missing outside of the subtype, add explanation.
822 -- No additional message if only one value is missing.
823
824 if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then
825 Explain_Non_Static_Bound;
826 end if;
827 end if;
828
829 for Outer_Index in 2 .. Num_Choices loop
830 Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
831 Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
832
833 if Choice_Lo <= Prev_Hi then
834 Choice := Choice_Table (Outer_Index).Node;
835
836 -- Find first previous choice that overlaps
837
838 for Inner_Index in 1 .. Outer_Index - 1 loop
839 if Choice_Lo <=
840 Expr_Value (Choice_Table (Inner_Index).Hi)
841 then
842 Prev_Choice := Choice_Table (Inner_Index).Node;
843 exit;
844 end if;
845 end loop;
846
847 if Sloc (Prev_Choice) <= Sloc (Choice) then
848 Error_Msg_Sloc := Sloc (Prev_Choice);
849 Dup_Choice
850 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
851 else
852 Error_Msg_Sloc := Sloc (Choice);
853 Dup_Choice
854 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
855 end if;
856
857 elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
858 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
859 end if;
860
861 if Choice_Hi > Prev_Hi then
862 Prev_Hi := Choice_Hi;
863 end if;
864 end loop;
865
866 if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then
867 Missing_Choice (Prev_Hi + 1, Bounds_Hi);
868
869 if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then
870 Explain_Non_Static_Bound;
871 end if;
872 end if;
873 end if;
874 end Check_Choice_Set;
875
876 ------------------
877 -- Choice_Image --
878 ------------------
879
880 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
881 Rtp : constant Entity_Id := Root_Type (Ctype);
882 Lit : Entity_Id;
883 C : Int;
884
885 begin
886 -- For character, or wide [wide] character. If 7-bit ASCII graphic
887 -- range, then build and return appropriate character literal name
888
889 if Is_Standard_Character_Type (Ctype) then
890 C := UI_To_Int (Value);
891
892 if C in 16#20# .. 16#7E# then
893 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
894 return Name_Find;
895 end if;
896
897 -- For user defined enumeration type, find enum/char literal
898
899 else
900 Lit := First_Literal (Rtp);
901
902 for J in 1 .. UI_To_Int (Value) loop
903 Next_Literal (Lit);
904 end loop;
905
906 -- If enumeration literal, just return its value
907
908 if Nkind (Lit) = N_Defining_Identifier then
909 return Chars (Lit);
910
911 -- For character literal, get the name and use it if it is
912 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
913
914 else
915 Get_Decoded_Name_String (Chars (Lit));
916
917 if Name_Len = 3
918 and then Name_Buffer (2) in
919 Character'Val (16#20#) .. Character'Val (16#7E#)
920 then
921 return Chars (Lit);
922 end if;
923 end if;
924 end if;
925
926 -- If we fall through, we have a character literal which is not in
927 -- the 7-bit ASCII graphic set. For such cases, we construct the
928 -- name "type'val(nnn)" where type is the choice type, and nnn is
929 -- the pos value passed as an argument to Choice_Image.
930
931 Get_Name_String (Chars (First_Subtype (Ctype)));
932
933 Add_Str_To_Name_Buffer ("'val(");
934 UI_Image (Value);
935 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
936 Add_Char_To_Name_Buffer (')');
937 return Name_Find;
938 end Choice_Image;
939
940 --------------------------
941 -- Expand_Others_Choice --
942 --------------------------
943
944 procedure Expand_Others_Choice
945 (Case_Table : Choice_Table_Type;
946 Others_Choice : Node_Id;
947 Choice_Type : Entity_Id)
948 is
949 Loc : constant Source_Ptr := Sloc (Others_Choice);
950 Choice_List : constant List_Id := New_List;
951 Choice : Node_Id;
952 Exp_Lo : Node_Id;
953 Exp_Hi : Node_Id;
954 Hi : Uint;
955 Lo : Uint;
956 Previous_Hi : Uint;
957
958 function Build_Choice (Value1, Value2 : Uint) return Node_Id;
959 -- Builds a node representing the missing choices given by Value1 and
960 -- Value2. A N_Range node is built if there is more than one literal
961 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
962 -- or N_Character_Literal is built depending on what Choice_Type is.
963
964 function Lit_Of (Value : Uint) return Node_Id;
965 -- Returns the Node_Id for the enumeration literal corresponding to the
966 -- position given by Value within the enumeration type Choice_Type.
967
968 ------------------
969 -- Build_Choice --
970 ------------------
971
972 function Build_Choice (Value1, Value2 : Uint) return Node_Id is
973 Lit_Node : Node_Id;
974 Lo, Hi : Node_Id;
975
976 begin
977 -- If there is only one choice value missing between Value1 and
978 -- Value2, build an integer or enumeration literal to represent it.
979
980 if (Value2 - Value1) = 0 then
981 if Is_Integer_Type (Choice_Type) then
982 Lit_Node := Make_Integer_Literal (Loc, Value1);
983 Set_Etype (Lit_Node, Choice_Type);
984 else
985 Lit_Node := Lit_Of (Value1);
986 end if;
987
988 -- Otherwise is more that one choice value that is missing between
989 -- Value1 and Value2, therefore build a N_Range node of either
990 -- integer or enumeration literals.
991
992 else
993 if Is_Integer_Type (Choice_Type) then
994 Lo := Make_Integer_Literal (Loc, Value1);
995 Set_Etype (Lo, Choice_Type);
996 Hi := Make_Integer_Literal (Loc, Value2);
997 Set_Etype (Hi, Choice_Type);
998 Lit_Node :=
999 Make_Range (Loc,
1000 Low_Bound => Lo,
1001 High_Bound => Hi);
1002
1003 else
1004 Lit_Node :=
1005 Make_Range (Loc,
1006 Low_Bound => Lit_Of (Value1),
1007 High_Bound => Lit_Of (Value2));
1008 end if;
1009 end if;
1010
1011 return Lit_Node;
1012 end Build_Choice;
1013
1014 ------------
1015 -- Lit_Of --
1016 ------------
1017
1018 function Lit_Of (Value : Uint) return Node_Id is
1019 Lit : Entity_Id;
1020
1021 begin
1022 -- In the case where the literal is of type Character, there needs
1023 -- to be some special handling since there is no explicit chain
1024 -- of literals to search. Instead, a N_Character_Literal node
1025 -- is created with the appropriate Char_Code and Chars fields.
1026
1027 if Is_Standard_Character_Type (Choice_Type) then
1028 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
1029 Lit := New_Node (N_Character_Literal, Loc);
1030 Set_Chars (Lit, Name_Find);
1031 Set_Char_Literal_Value (Lit, Value);
1032 Set_Etype (Lit, Choice_Type);
1033 Set_Is_Static_Expression (Lit, True);
1034 return Lit;
1035
1036 -- Otherwise, iterate through the literals list of Choice_Type
1037 -- "Value" number of times until the desired literal is reached
1038 -- and then return an occurrence of it.
1039
1040 else
1041 Lit := First_Literal (Choice_Type);
1042 for J in 1 .. UI_To_Int (Value) loop
1043 Next_Literal (Lit);
1044 end loop;
1045
1046 return New_Occurrence_Of (Lit, Loc);
1047 end if;
1048 end Lit_Of;
1049
1050 -- Start of processing for Expand_Others_Choice
1051
1052 begin
1053 if Case_Table'Last = 0 then
1054
1055 -- Special case: only an others case is present. The others case
1056 -- covers the full range of the type.
1057
1058 if Is_OK_Static_Subtype (Choice_Type) then
1059 Choice := New_Occurrence_Of (Choice_Type, Loc);
1060 else
1061 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
1062 end if;
1063
1064 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
1065 return;
1066 end if;
1067
1068 -- Establish the bound values for the choice depending upon whether the
1069 -- type of the case statement is static or not.
1070
1071 if Is_OK_Static_Subtype (Choice_Type) then
1072 Exp_Lo := Type_Low_Bound (Choice_Type);
1073 Exp_Hi := Type_High_Bound (Choice_Type);
1074 else
1075 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
1076 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
1077 end if;
1078
1079 Lo := Expr_Value (Case_Table (1).Lo);
1080 Hi := Expr_Value (Case_Table (1).Hi);
1081 Previous_Hi := Expr_Value (Case_Table (1).Hi);
1082
1083 -- Build the node for any missing choices that are smaller than any
1084 -- explicit choices given in the case.
1085
1086 if Expr_Value (Exp_Lo) < Lo then
1087 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
1088 end if;
1089
1090 -- Build the nodes representing any missing choices that lie between
1091 -- the explicit ones given in the case.
1092
1093 for J in 2 .. Case_Table'Last loop
1094 Lo := Expr_Value (Case_Table (J).Lo);
1095 Hi := Expr_Value (Case_Table (J).Hi);
1096
1097 if Lo /= (Previous_Hi + 1) then
1098 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
1099 end if;
1100
1101 Previous_Hi := Hi;
1102 end loop;
1103
1104 -- Build the node for any missing choices that are greater than any
1105 -- explicit choices given in the case.
1106
1107 if Expr_Value (Exp_Hi) > Hi then
1108 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
1109 end if;
1110
1111 Set_Others_Discrete_Choices (Others_Choice, Choice_List);
1112
1113 -- Warn on null others list if warning option set
1114
1115 if Warn_On_Redundant_Constructs
1116 and then Comes_From_Source (Others_Choice)
1117 and then Is_Empty_List (Choice_List)
1118 then
1119 Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice);
1120 Error_Msg_N ("\?r?previous choices cover all values", Others_Choice);
1121 end if;
1122 end Expand_Others_Choice;
1123
1124 -----------
1125 -- No_OP --
1126 -----------
1127
1128 procedure No_OP (C : Node_Id) is
1129 begin
1130 if Nkind (C) = N_Range and then Warn_On_Redundant_Constructs then
1131 Error_Msg_N ("choice is an empty range?r?", C);
1132 end if;
1133 end No_OP;
1134
1135 -----------------------------
1136 -- Generic_Analyze_Choices --
1137 -----------------------------
1138
1139 package body Generic_Analyze_Choices is
1140
1141 -- The following type is used to gather the entries for the choice
1142 -- table, so that we can then allocate the right length.
1143
1144 type Link;
1145 type Link_Ptr is access all Link;
1146
1147 type Link is record
1148 Val : Choice_Bounds;
1149 Nxt : Link_Ptr;
1150 end record;
1151
1152 ---------------------
1153 -- Analyze_Choices --
1154 ---------------------
1155
1156 procedure Analyze_Choices
1157 (Alternatives : List_Id;
1158 Subtyp : Entity_Id)
1159 is
1160 Choice_Type : constant Entity_Id := Base_Type (Subtyp);
1161 -- The actual type against which the discrete choices are resolved.
1162 -- Note that this type is always the base type not the subtype of the
1163 -- ruling expression, index or discriminant.
1164
1165 Expected_Type : Entity_Id;
1166 -- The expected type of each choice. Equal to Choice_Type, except if
1167 -- the expression is universal, in which case the choices can be of
1168 -- any integer type.
1169
1170 Alt : Node_Id;
1171 -- A case statement alternative or a variant in a record type
1172 -- declaration.
1173
1174 Choice : Node_Id;
1175 Kind : Node_Kind;
1176 -- The node kind of the current Choice
1177
1178 begin
1179 -- Set Expected type (= choice type except for universal integer,
1180 -- where we accept any integer type as a choice).
1181
1182 if Choice_Type = Universal_Integer then
1183 Expected_Type := Any_Integer;
1184 else
1185 Expected_Type := Choice_Type;
1186 end if;
1187
1188 -- Now loop through the case alternatives or record variants
1189
1190 Alt := First (Alternatives);
1191 while Present (Alt) loop
1192
1193 -- If pragma, just analyze it
1194
1195 if Nkind (Alt) = N_Pragma then
1196 Analyze (Alt);
1197
1198 -- Otherwise we have an alternative. In most cases the semantic
1199 -- processing leaves the list of choices unchanged
1200
1201 -- Check each choice against its base type
1202
1203 else
1204 Choice := First (Discrete_Choices (Alt));
1205 while Present (Choice) loop
1206 Analyze (Choice);
1207 Kind := Nkind (Choice);
1208
1209 -- Choice is a Range
1210
1211 if Kind = N_Range
1212 or else (Kind = N_Attribute_Reference
1213 and then Attribute_Name (Choice) = Name_Range)
1214 then
1215 Resolve (Choice, Expected_Type);
1216
1217 -- Choice is a subtype name, nothing further to do now
1218
1219 elsif Is_Entity_Name (Choice)
1220 and then Is_Type (Entity (Choice))
1221 then
1222 null;
1223
1224 -- Choice is a subtype indication
1225
1226 elsif Kind = N_Subtype_Indication then
1227 Resolve_Discrete_Subtype_Indication
1228 (Choice, Expected_Type);
1229
1230 -- Others choice, no analysis needed
1231
1232 elsif Kind = N_Others_Choice then
1233 null;
1234
1235 -- Only other possibility is an expression
1236
1237 else
1238 Resolve (Choice, Expected_Type);
1239 end if;
1240
1241 -- Move to next choice
1242
1243 Next (Choice);
1244 end loop;
1245
1246 Process_Associated_Node (Alt);
1247 end if;
1248
1249 Next (Alt);
1250 end loop;
1251 end Analyze_Choices;
1252
1253 end Generic_Analyze_Choices;
1254
1255 ---------------------------
1256 -- Generic_Check_Choices --
1257 ---------------------------
1258
1259 package body Generic_Check_Choices is
1260
1261 -- The following type is used to gather the entries for the choice
1262 -- table, so that we can then allocate the right length.
1263
1264 type Link;
1265 type Link_Ptr is access all Link;
1266
1267 type Link is record
1268 Val : Choice_Bounds;
1269 Nxt : Link_Ptr;
1270 end record;
1271
1272 procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
1273
1274 -------------------
1275 -- Check_Choices --
1276 -------------------
1277
1278 procedure Check_Choices
1279 (N : Node_Id;
1280 Alternatives : List_Id;
1281 Subtyp : Entity_Id;
1282 Others_Present : out Boolean)
1283 is
1284 E : Entity_Id;
1285
1286 Raises_CE : Boolean;
1287 -- Set True if one of the bounds of a choice raises CE
1288
1289 Enode : Node_Id;
1290 -- This is where we post error messages for bounds out of range
1291
1292 Choice_List : Link_Ptr := null;
1293 -- Gather list of choices
1294
1295 Num_Choices : Nat := 0;
1296 -- Number of entries in Choice_List
1297
1298 Choice_Type : constant Entity_Id := Base_Type (Subtyp);
1299 -- The actual type against which the discrete choices are resolved.
1300 -- Note that this type is always the base type not the subtype of the
1301 -- ruling expression, index or discriminant.
1302
1303 Bounds_Type : Entity_Id;
1304 -- The type from which are derived the bounds of the values covered
1305 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1306 -- specifies a value outside of these bounds we have an error.
1307
1308 Bounds_Lo : Uint;
1309 Bounds_Hi : Uint;
1310 -- The actual bounds of the above type
1311
1312 Expected_Type : Entity_Id;
1313 -- The expected type of each choice. Equal to Choice_Type, except if
1314 -- the expression is universal, in which case the choices can be of
1315 -- any integer type.
1316
1317 Alt : Node_Id;
1318 -- A case statement alternative or a variant in a record type
1319 -- declaration.
1320
1321 Choice : Node_Id;
1322 Kind : Node_Kind;
1323 -- The node kind of the current Choice
1324
1325 Others_Choice : Node_Id := Empty;
1326 -- Remember others choice if it is present (empty otherwise)
1327
1328 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
1329 -- Checks the validity of the bounds of a choice. When the bounds
1330 -- are static and no error occurred the bounds are collected for
1331 -- later entry into the choices table so that they can be sorted
1332 -- later on.
1333
1334 -----------
1335 -- Check --
1336 -----------
1337
1338 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
1339 Lo_Val : Uint;
1340 Hi_Val : Uint;
1341
1342 begin
1343 -- First check if an error was already detected on either bounds
1344
1345 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
1346 return;
1347
1348 -- Do not insert non static choices in the table to be sorted
1349
1350 elsif not Is_OK_Static_Expression (Lo)
1351 or else
1352 not Is_OK_Static_Expression (Hi)
1353 then
1354 Process_Non_Static_Choice (Choice);
1355 return;
1356
1357 -- Ignore range which raise constraint error
1358
1359 elsif Raises_Constraint_Error (Lo)
1360 or else Raises_Constraint_Error (Hi)
1361 then
1362 Raises_CE := True;
1363 return;
1364
1365 -- AI05-0188 : Within an instance the non-others choices do not
1366 -- have to belong to the actual subtype.
1367
1368 elsif Ada_Version >= Ada_2012 and then In_Instance then
1369 return;
1370
1371 -- Otherwise we have an OK static choice
1372
1373 else
1374 Lo_Val := Expr_Value (Lo);
1375 Hi_Val := Expr_Value (Hi);
1376
1377 -- Do not insert null ranges in the choices table
1378
1379 if Lo_Val > Hi_Val then
1380 Process_Empty_Choice (Choice);
1381 return;
1382 end if;
1383 end if;
1384
1385 -- Check for low bound out of range
1386
1387 if Lo_Val < Bounds_Lo then
1388
1389 -- If the choice is an entity name, then it is a type, and we
1390 -- want to post the message on the reference to this entity.
1391 -- Otherwise post it on the lower bound of the range.
1392
1393 if Is_Entity_Name (Choice) then
1394 Enode := Choice;
1395 else
1396 Enode := Lo;
1397 end if;
1398
1399 -- Specialize message for integer/enum type
1400
1401 if Is_Integer_Type (Bounds_Type) then
1402 Error_Msg_Uint_1 := Bounds_Lo;
1403 Error_Msg_N ("minimum allowed choice value is^", Enode);
1404 else
1405 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
1406 Error_Msg_N ("minimum allowed choice value is%", Enode);
1407 end if;
1408 end if;
1409
1410 -- Check for high bound out of range
1411
1412 if Hi_Val > Bounds_Hi then
1413
1414 -- If the choice is an entity name, then it is a type, and we
1415 -- want to post the message on the reference to this entity.
1416 -- Otherwise post it on the upper bound of the range.
1417
1418 if Is_Entity_Name (Choice) then
1419 Enode := Choice;
1420 else
1421 Enode := Hi;
1422 end if;
1423
1424 -- Specialize message for integer/enum type
1425
1426 if Is_Integer_Type (Bounds_Type) then
1427 Error_Msg_Uint_1 := Bounds_Hi;
1428 Error_Msg_N ("maximum allowed choice value is^", Enode);
1429 else
1430 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
1431 Error_Msg_N ("maximum allowed choice value is%", Enode);
1432 end if;
1433 end if;
1434
1435 -- Collect bounds in the list
1436
1437 -- Note: we still store the bounds, even if they are out of range,
1438 -- since this may prevent unnecessary cascaded errors for values
1439 -- that are covered by such an excessive range.
1440
1441 Choice_List :=
1442 new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1443 Num_Choices := Num_Choices + 1;
1444 end Check;
1445
1446 -- Start of processing for Check_Choices
1447
1448 begin
1449 Raises_CE := False;
1450 Others_Present := False;
1451
1452 -- If Subtyp is not a discrete type or there was some other error,
1453 -- then don't try any semantic checking on the choices since we have
1454 -- a complete mess.
1455
1456 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
1457 return;
1458 end if;
1459
1460 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1461 -- bounds of its base type to determine the values covered by the
1462 -- discrete choices.
1463
1464 -- In Ada 2012, if the subtype has a non-static predicate the full
1465 -- range of the base type must be covered as well.
1466
1467 if Is_OK_Static_Subtype (Subtyp) then
1468 if not Has_Predicates (Subtyp)
1469 or else Has_Static_Predicate (Subtyp)
1470 then
1471 Bounds_Type := Subtyp;
1472 else
1473 Bounds_Type := Choice_Type;
1474 end if;
1475
1476 else
1477 Bounds_Type := Choice_Type;
1478 end if;
1479
1480 -- Obtain static bounds of type, unless this is a generic formal
1481 -- discrete type for which all choices will be non-static.
1482
1483 if not Is_Generic_Type (Root_Type (Bounds_Type))
1484 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1485 then
1486 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1487 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1488 end if;
1489
1490 if Choice_Type = Universal_Integer then
1491 Expected_Type := Any_Integer;
1492 else
1493 Expected_Type := Choice_Type;
1494 end if;
1495
1496 -- Now loop through the case alternatives or record variants
1497
1498 Alt := First (Alternatives);
1499 while Present (Alt) loop
1500
1501 -- If pragma, just analyze it
1502
1503 if Nkind (Alt) = N_Pragma then
1504 Analyze (Alt);
1505
1506 -- Otherwise we have an alternative. In most cases the semantic
1507 -- processing leaves the list of choices unchanged
1508
1509 -- Check each choice against its base type
1510
1511 else
1512 Choice := First (Discrete_Choices (Alt));
1513 while Present (Choice) loop
1514 Kind := Nkind (Choice);
1515
1516 -- Choice is a Range
1517
1518 if Kind = N_Range
1519 or else (Kind = N_Attribute_Reference
1520 and then Attribute_Name (Choice) = Name_Range)
1521 then
1522 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1523
1524 -- Choice is a subtype name
1525
1526 elsif Is_Entity_Name (Choice)
1527 and then Is_Type (Entity (Choice))
1528 then
1529 -- Check for inappropriate type
1530
1531 if not Covers (Expected_Type, Etype (Choice)) then
1532 Wrong_Type (Choice, Choice_Type);
1533
1534 -- Type is OK, so check further
1535
1536 else
1537 E := Entity (Choice);
1538
1539 -- Case of predicated subtype
1540
1541 if Has_Predicates (E) then
1542
1543 -- Use of non-static predicate is an error
1544
1545 if not Is_Discrete_Type (E)
1546 or else not Has_Static_Predicate (E)
1547 or else Has_Dynamic_Predicate_Aspect (E)
1548 then
1549 Bad_Predicated_Subtype_Use
1550 ("cannot use subtype& with non-static "
1551 & "predicate as case alternative",
1552 Choice, E, Suggest_Static => True);
1553
1554 -- Static predicate case
1555
1556 else
1557 declare
1558 P : Node_Id;
1559 C : Node_Id;
1560
1561 begin
1562 -- Loop through entries in predicate list,
1563 -- checking each entry. Note that if the
1564 -- list is empty, corresponding to a False
1565 -- predicate, then no choices are checked.
1566
1567 P := First (Static_Discrete_Predicate (E));
1568 while Present (P) loop
1569 C := New_Copy (P);
1570 Set_Sloc (C, Sloc (Choice));
1571 Check (C, Low_Bound (C), High_Bound (C));
1572 Next (P);
1573 end loop;
1574 end;
1575
1576 Set_Has_SP_Choice (Alt);
1577 end if;
1578
1579 -- Not predicated subtype case
1580
1581 elsif not Is_OK_Static_Subtype (E) then
1582 Process_Non_Static_Choice (Choice);
1583 else
1584 Check
1585 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1586 end if;
1587 end if;
1588
1589 -- Choice is a subtype indication
1590
1591 elsif Kind = N_Subtype_Indication then
1592 Resolve_Discrete_Subtype_Indication
1593 (Choice, Expected_Type);
1594
1595 if Etype (Choice) /= Any_Type then
1596 declare
1597 C : constant Node_Id := Constraint (Choice);
1598 R : constant Node_Id := Range_Expression (C);
1599 L : constant Node_Id := Low_Bound (R);
1600 H : constant Node_Id := High_Bound (R);
1601
1602 begin
1603 E := Entity (Subtype_Mark (Choice));
1604
1605 if not Is_OK_Static_Subtype (E) then
1606 Process_Non_Static_Choice (Choice);
1607
1608 else
1609 if Is_OK_Static_Expression (L)
1610 and then
1611 Is_OK_Static_Expression (H)
1612 then
1613 if Expr_Value (L) > Expr_Value (H) then
1614 Process_Empty_Choice (Choice);
1615 else
1616 if Is_Out_Of_Range (L, E) then
1617 Apply_Compile_Time_Constraint_Error
1618 (L, "static value out of range",
1619 CE_Range_Check_Failed);
1620 end if;
1621
1622 if Is_Out_Of_Range (H, E) then
1623 Apply_Compile_Time_Constraint_Error
1624 (H, "static value out of range",
1625 CE_Range_Check_Failed);
1626 end if;
1627 end if;
1628 end if;
1629
1630 Check (Choice, L, H);
1631 end if;
1632 end;
1633 end if;
1634
1635 -- The others choice is only allowed for the last
1636 -- alternative and as its only choice.
1637
1638 elsif Kind = N_Others_Choice then
1639 if not (Choice = First (Discrete_Choices (Alt))
1640 and then Choice = Last (Discrete_Choices (Alt))
1641 and then Alt = Last (Alternatives))
1642 then
1643 Error_Msg_N
1644 ("the choice OTHERS must appear alone and last",
1645 Choice);
1646 return;
1647 end if;
1648
1649 Others_Present := True;
1650 Others_Choice := Choice;
1651
1652 -- Only other possibility is an expression
1653
1654 else
1655 Check (Choice, Choice, Choice);
1656 end if;
1657
1658 -- Move to next choice
1659
1660 Next (Choice);
1661 end loop;
1662
1663 Process_Associated_Node (Alt);
1664 end if;
1665
1666 Next (Alt);
1667 end loop;
1668
1669 -- Now we can create the Choice_Table, since we know how long
1670 -- it needs to be so we can allocate exactly the right length.
1671
1672 declare
1673 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1674
1675 begin
1676 -- Now copy the items we collected in the linked list into this
1677 -- newly allocated table (leave entry 0 unused for sorting).
1678
1679 declare
1680 T : Link_Ptr;
1681 begin
1682 for J in 1 .. Num_Choices loop
1683 T := Choice_List;
1684 Choice_List := T.Nxt;
1685 Choice_Table (J) := T.Val;
1686 Free (T);
1687 end loop;
1688 end;
1689
1690 Check_Choice_Set
1691 (Choice_Table,
1692 Bounds_Type,
1693 Subtyp,
1694 Others_Present or else (Choice_Type = Universal_Integer),
1695 N);
1696
1697 -- If no others choice we are all done, otherwise we have one more
1698 -- step, which is to set the Others_Discrete_Choices field of the
1699 -- others choice (to contain all otherwise unspecified choices).
1700 -- Skip this if CE is known to be raised.
1701
1702 if Others_Present and not Raises_CE then
1703 Expand_Others_Choice
1704 (Case_Table => Choice_Table,
1705 Others_Choice => Others_Choice,
1706 Choice_Type => Bounds_Type);
1707 end if;
1708 end;
1709 end Check_Choices;
1710
1711 end Generic_Check_Choices;
1712
1713 end Sem_Case;