?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2015-09-28 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / ada / sem_case.adb
blob201855b5e364518ee93f0a2fc7db5f5f1f7deb5b
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-2014, 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 Prev_Lo := Uint_Minus_1;
770 Prev_Hi := Uint_Minus_1;
771 Error := False;
772
773 for Index in 1 .. Num_Choices loop
774 Check_Against_Predicate
775 (Pred => Pred,
776 Choice => Choice_Table (Index),
777 Prev_Lo => Prev_Lo,
778 Prev_Hi => Prev_Hi,
779 Error => Error);
780
781 -- The analysis detected an illegal intersection between a choice
782 -- and a static predicate set. Do not examine other choices unless
783 -- all errors are requested.
784
785 if Error then
786 Predicate_Error := True;
787
788 if not All_Errors_Mode then
789 return;
790 end if;
791 end if;
792 end loop;
793
794 if Predicate_Error then
795 return;
796 end if;
797
798 -- The choices may legally cover some of the static predicate sets,
799 -- but not all. Emit an error for each non-covered set.
800
801 if not Others_Present then
802 Missing_Choices (Pred, Prev_Hi);
803 end if;
804
805 -- Default analysis
806
807 else
808 Choice_Lo := Expr_Value (Choice_Table (1).Lo);
809 Choice_Hi := Expr_Value (Choice_Table (1).Hi);
810 Prev_Hi := Choice_Hi;
811
812 if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then
813 Missing_Choice (Bounds_Lo, Choice_Lo - 1);
814
815 -- If values are missing outside of the subtype, add explanation.
816 -- No additional message if only one value is missing.
817
818 if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then
819 Explain_Non_Static_Bound;
820 end if;
821 end if;
822
823 for Outer_Index in 2 .. Num_Choices loop
824 Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
825 Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
826
827 if Choice_Lo <= Prev_Hi then
828 Choice := Choice_Table (Outer_Index).Node;
829
830 -- Find first previous choice that overlaps
831
832 for Inner_Index in 1 .. Outer_Index - 1 loop
833 if Choice_Lo <=
834 Expr_Value (Choice_Table (Inner_Index).Hi)
835 then
836 Prev_Choice := Choice_Table (Inner_Index).Node;
837 exit;
838 end if;
839 end loop;
840
841 if Sloc (Prev_Choice) <= Sloc (Choice) then
842 Error_Msg_Sloc := Sloc (Prev_Choice);
843 Dup_Choice
844 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
845 else
846 Error_Msg_Sloc := Sloc (Choice);
847 Dup_Choice
848 (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
849 end if;
850
851 elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
852 Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
853 end if;
854
855 if Choice_Hi > Prev_Hi then
856 Prev_Hi := Choice_Hi;
857 end if;
858 end loop;
859
860 if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then
861 Missing_Choice (Prev_Hi + 1, Bounds_Hi);
862
863 if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then
864 Explain_Non_Static_Bound;
865 end if;
866 end if;
867 end if;
868 end Check_Choice_Set;
869
870 ------------------
871 -- Choice_Image --
872 ------------------
873
874 function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
875 Rtp : constant Entity_Id := Root_Type (Ctype);
876 Lit : Entity_Id;
877 C : Int;
878
879 begin
880 -- For character, or wide [wide] character. If 7-bit ASCII graphic
881 -- range, then build and return appropriate character literal name
882
883 if Is_Standard_Character_Type (Ctype) then
884 C := UI_To_Int (Value);
885
886 if C in 16#20# .. 16#7E# then
887 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
888 return Name_Find;
889 end if;
890
891 -- For user defined enumeration type, find enum/char literal
892
893 else
894 Lit := First_Literal (Rtp);
895
896 for J in 1 .. UI_To_Int (Value) loop
897 Next_Literal (Lit);
898 end loop;
899
900 -- If enumeration literal, just return its value
901
902 if Nkind (Lit) = N_Defining_Identifier then
903 return Chars (Lit);
904
905 -- For character literal, get the name and use it if it is
906 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
907
908 else
909 Get_Decoded_Name_String (Chars (Lit));
910
911 if Name_Len = 3
912 and then Name_Buffer (2) in
913 Character'Val (16#20#) .. Character'Val (16#7E#)
914 then
915 return Chars (Lit);
916 end if;
917 end if;
918 end if;
919
920 -- If we fall through, we have a character literal which is not in
921 -- the 7-bit ASCII graphic set. For such cases, we construct the
922 -- name "type'val(nnn)" where type is the choice type, and nnn is
923 -- the pos value passed as an argument to Choice_Image.
924
925 Get_Name_String (Chars (First_Subtype (Ctype)));
926
927 Add_Str_To_Name_Buffer ("'val(");
928 UI_Image (Value);
929 Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
930 Add_Char_To_Name_Buffer (')');
931 return Name_Find;
932 end Choice_Image;
933
934 --------------------------
935 -- Expand_Others_Choice --
936 --------------------------
937
938 procedure Expand_Others_Choice
939 (Case_Table : Choice_Table_Type;
940 Others_Choice : Node_Id;
941 Choice_Type : Entity_Id)
942 is
943 Loc : constant Source_Ptr := Sloc (Others_Choice);
944 Choice_List : constant List_Id := New_List;
945 Choice : Node_Id;
946 Exp_Lo : Node_Id;
947 Exp_Hi : Node_Id;
948 Hi : Uint;
949 Lo : Uint;
950 Previous_Hi : Uint;
951
952 function Build_Choice (Value1, Value2 : Uint) return Node_Id;
953 -- Builds a node representing the missing choices given by Value1 and
954 -- Value2. A N_Range node is built if there is more than one literal
955 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
956 -- or N_Character_Literal is built depending on what Choice_Type is.
957
958 function Lit_Of (Value : Uint) return Node_Id;
959 -- Returns the Node_Id for the enumeration literal corresponding to the
960 -- position given by Value within the enumeration type Choice_Type.
961
962 ------------------
963 -- Build_Choice --
964 ------------------
965
966 function Build_Choice (Value1, Value2 : Uint) return Node_Id is
967 Lit_Node : Node_Id;
968 Lo, Hi : Node_Id;
969
970 begin
971 -- If there is only one choice value missing between Value1 and
972 -- Value2, build an integer or enumeration literal to represent it.
973
974 if (Value2 - Value1) = 0 then
975 if Is_Integer_Type (Choice_Type) then
976 Lit_Node := Make_Integer_Literal (Loc, Value1);
977 Set_Etype (Lit_Node, Choice_Type);
978 else
979 Lit_Node := Lit_Of (Value1);
980 end if;
981
982 -- Otherwise is more that one choice value that is missing between
983 -- Value1 and Value2, therefore build a N_Range node of either
984 -- integer or enumeration literals.
985
986 else
987 if Is_Integer_Type (Choice_Type) then
988 Lo := Make_Integer_Literal (Loc, Value1);
989 Set_Etype (Lo, Choice_Type);
990 Hi := Make_Integer_Literal (Loc, Value2);
991 Set_Etype (Hi, Choice_Type);
992 Lit_Node :=
993 Make_Range (Loc,
994 Low_Bound => Lo,
995 High_Bound => Hi);
996
997 else
998 Lit_Node :=
999 Make_Range (Loc,
1000 Low_Bound => Lit_Of (Value1),
1001 High_Bound => Lit_Of (Value2));
1002 end if;
1003 end if;
1004
1005 return Lit_Node;
1006 end Build_Choice;
1007
1008 ------------
1009 -- Lit_Of --
1010 ------------
1011
1012 function Lit_Of (Value : Uint) return Node_Id is
1013 Lit : Entity_Id;
1014
1015 begin
1016 -- In the case where the literal is of type Character, there needs
1017 -- to be some special handling since there is no explicit chain
1018 -- of literals to search. Instead, a N_Character_Literal node
1019 -- is created with the appropriate Char_Code and Chars fields.
1020
1021 if Is_Standard_Character_Type (Choice_Type) then
1022 Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
1023 Lit := New_Node (N_Character_Literal, Loc);
1024 Set_Chars (Lit, Name_Find);
1025 Set_Char_Literal_Value (Lit, Value);
1026 Set_Etype (Lit, Choice_Type);
1027 Set_Is_Static_Expression (Lit, True);
1028 return Lit;
1029
1030 -- Otherwise, iterate through the literals list of Choice_Type
1031 -- "Value" number of times until the desired literal is reached
1032 -- and then return an occurrence of it.
1033
1034 else
1035 Lit := First_Literal (Choice_Type);
1036 for J in 1 .. UI_To_Int (Value) loop
1037 Next_Literal (Lit);
1038 end loop;
1039
1040 return New_Occurrence_Of (Lit, Loc);
1041 end if;
1042 end Lit_Of;
1043
1044 -- Start of processing for Expand_Others_Choice
1045
1046 begin
1047 if Case_Table'Last = 0 then
1048
1049 -- Special case: only an others case is present. The others case
1050 -- covers the full range of the type.
1051
1052 if Is_OK_Static_Subtype (Choice_Type) then
1053 Choice := New_Occurrence_Of (Choice_Type, Loc);
1054 else
1055 Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
1056 end if;
1057
1058 Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
1059 return;
1060 end if;
1061
1062 -- Establish the bound values for the choice depending upon whether the
1063 -- type of the case statement is static or not.
1064
1065 if Is_OK_Static_Subtype (Choice_Type) then
1066 Exp_Lo := Type_Low_Bound (Choice_Type);
1067 Exp_Hi := Type_High_Bound (Choice_Type);
1068 else
1069 Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
1070 Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
1071 end if;
1072
1073 Lo := Expr_Value (Case_Table (1).Lo);
1074 Hi := Expr_Value (Case_Table (1).Hi);
1075 Previous_Hi := Expr_Value (Case_Table (1).Hi);
1076
1077 -- Build the node for any missing choices that are smaller than any
1078 -- explicit choices given in the case.
1079
1080 if Expr_Value (Exp_Lo) < Lo then
1081 Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
1082 end if;
1083
1084 -- Build the nodes representing any missing choices that lie between
1085 -- the explicit ones given in the case.
1086
1087 for J in 2 .. Case_Table'Last loop
1088 Lo := Expr_Value (Case_Table (J).Lo);
1089 Hi := Expr_Value (Case_Table (J).Hi);
1090
1091 if Lo /= (Previous_Hi + 1) then
1092 Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
1093 end if;
1094
1095 Previous_Hi := Hi;
1096 end loop;
1097
1098 -- Build the node for any missing choices that are greater than any
1099 -- explicit choices given in the case.
1100
1101 if Expr_Value (Exp_Hi) > Hi then
1102 Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
1103 end if;
1104
1105 Set_Others_Discrete_Choices (Others_Choice, Choice_List);
1106
1107 -- Warn on null others list if warning option set
1108
1109 if Warn_On_Redundant_Constructs
1110 and then Comes_From_Source (Others_Choice)
1111 and then Is_Empty_List (Choice_List)
1112 then
1113 Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice);
1114 Error_Msg_N ("\?r?previous choices cover all values", Others_Choice);
1115 end if;
1116 end Expand_Others_Choice;
1117
1118 -----------
1119 -- No_OP --
1120 -----------
1121
1122 procedure No_OP (C : Node_Id) is
1123 pragma Warnings (Off, C);
1124 begin
1125 null;
1126 end No_OP;
1127
1128 -----------------------------
1129 -- Generic_Analyze_Choices --
1130 -----------------------------
1131
1132 package body Generic_Analyze_Choices is
1133
1134 -- The following type is used to gather the entries for the choice
1135 -- table, so that we can then allocate the right length.
1136
1137 type Link;
1138 type Link_Ptr is access all Link;
1139
1140 type Link is record
1141 Val : Choice_Bounds;
1142 Nxt : Link_Ptr;
1143 end record;
1144
1145 ---------------------
1146 -- Analyze_Choices --
1147 ---------------------
1148
1149 procedure Analyze_Choices
1150 (Alternatives : List_Id;
1151 Subtyp : Entity_Id)
1152 is
1153 Choice_Type : constant Entity_Id := Base_Type (Subtyp);
1154 -- The actual type against which the discrete choices are resolved.
1155 -- Note that this type is always the base type not the subtype of the
1156 -- ruling expression, index or discriminant.
1157
1158 Expected_Type : Entity_Id;
1159 -- The expected type of each choice. Equal to Choice_Type, except if
1160 -- the expression is universal, in which case the choices can be of
1161 -- any integer type.
1162
1163 Alt : Node_Id;
1164 -- A case statement alternative or a variant in a record type
1165 -- declaration.
1166
1167 Choice : Node_Id;
1168 Kind : Node_Kind;
1169 -- The node kind of the current Choice
1170
1171 begin
1172 -- Set Expected type (= choice type except for universal integer,
1173 -- where we accept any integer type as a choice).
1174
1175 if Choice_Type = Universal_Integer then
1176 Expected_Type := Any_Integer;
1177 else
1178 Expected_Type := Choice_Type;
1179 end if;
1180
1181 -- Now loop through the case alternatives or record variants
1182
1183 Alt := First (Alternatives);
1184 while Present (Alt) loop
1185
1186 -- If pragma, just analyze it
1187
1188 if Nkind (Alt) = N_Pragma then
1189 Analyze (Alt);
1190
1191 -- Otherwise we have an alternative. In most cases the semantic
1192 -- processing leaves the list of choices unchanged
1193
1194 -- Check each choice against its base type
1195
1196 else
1197 Choice := First (Discrete_Choices (Alt));
1198 while Present (Choice) loop
1199 Analyze (Choice);
1200 Kind := Nkind (Choice);
1201
1202 -- Choice is a Range
1203
1204 if Kind = N_Range
1205 or else (Kind = N_Attribute_Reference
1206 and then Attribute_Name (Choice) = Name_Range)
1207 then
1208 Resolve (Choice, Expected_Type);
1209
1210 -- Choice is a subtype name, nothing further to do now
1211
1212 elsif Is_Entity_Name (Choice)
1213 and then Is_Type (Entity (Choice))
1214 then
1215 null;
1216
1217 -- Choice is a subtype indication
1218
1219 elsif Kind = N_Subtype_Indication then
1220 Resolve_Discrete_Subtype_Indication
1221 (Choice, Expected_Type);
1222
1223 -- Others choice, no analysis needed
1224
1225 elsif Kind = N_Others_Choice then
1226 null;
1227
1228 -- Only other possibility is an expression
1229
1230 else
1231 Resolve (Choice, Expected_Type);
1232 end if;
1233
1234 -- Move to next choice
1235
1236 Next (Choice);
1237 end loop;
1238
1239 Process_Associated_Node (Alt);
1240 end if;
1241
1242 Next (Alt);
1243 end loop;
1244 end Analyze_Choices;
1245
1246 end Generic_Analyze_Choices;
1247
1248 ---------------------------
1249 -- Generic_Check_Choices --
1250 ---------------------------
1251
1252 package body Generic_Check_Choices is
1253
1254 -- The following type is used to gather the entries for the choice
1255 -- table, so that we can then allocate the right length.
1256
1257 type Link;
1258 type Link_Ptr is access all Link;
1259
1260 type Link is record
1261 Val : Choice_Bounds;
1262 Nxt : Link_Ptr;
1263 end record;
1264
1265 procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
1266
1267 -------------------
1268 -- Check_Choices --
1269 -------------------
1270
1271 procedure Check_Choices
1272 (N : Node_Id;
1273 Alternatives : List_Id;
1274 Subtyp : Entity_Id;
1275 Others_Present : out Boolean)
1276 is
1277 E : Entity_Id;
1278
1279 Raises_CE : Boolean;
1280 -- Set True if one of the bounds of a choice raises CE
1281
1282 Enode : Node_Id;
1283 -- This is where we post error messages for bounds out of range
1284
1285 Choice_List : Link_Ptr := null;
1286 -- Gather list of choices
1287
1288 Num_Choices : Nat := 0;
1289 -- Number of entries in Choice_List
1290
1291 Choice_Type : constant Entity_Id := Base_Type (Subtyp);
1292 -- The actual type against which the discrete choices are resolved.
1293 -- Note that this type is always the base type not the subtype of the
1294 -- ruling expression, index or discriminant.
1295
1296 Bounds_Type : Entity_Id;
1297 -- The type from which are derived the bounds of the values covered
1298 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1299 -- specifies a value outside of these bounds we have an error.
1300
1301 Bounds_Lo : Uint;
1302 Bounds_Hi : Uint;
1303 -- The actual bounds of the above type
1304
1305 Expected_Type : Entity_Id;
1306 -- The expected type of each choice. Equal to Choice_Type, except if
1307 -- the expression is universal, in which case the choices can be of
1308 -- any integer type.
1309
1310 Alt : Node_Id;
1311 -- A case statement alternative or a variant in a record type
1312 -- declaration.
1313
1314 Choice : Node_Id;
1315 Kind : Node_Kind;
1316 -- The node kind of the current Choice
1317
1318 Others_Choice : Node_Id := Empty;
1319 -- Remember others choice if it is present (empty otherwise)
1320
1321 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
1322 -- Checks the validity of the bounds of a choice. When the bounds
1323 -- are static and no error occurred the bounds are collected for
1324 -- later entry into the choices table so that they can be sorted
1325 -- later on.
1326
1327 -----------
1328 -- Check --
1329 -----------
1330
1331 procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
1332 Lo_Val : Uint;
1333 Hi_Val : Uint;
1334
1335 begin
1336 -- First check if an error was already detected on either bounds
1337
1338 if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
1339 return;
1340
1341 -- Do not insert non static choices in the table to be sorted
1342
1343 elsif not Is_OK_Static_Expression (Lo)
1344 or else
1345 not Is_OK_Static_Expression (Hi)
1346 then
1347 Process_Non_Static_Choice (Choice);
1348 return;
1349
1350 -- Ignore range which raise constraint error
1351
1352 elsif Raises_Constraint_Error (Lo)
1353 or else Raises_Constraint_Error (Hi)
1354 then
1355 Raises_CE := True;
1356 return;
1357
1358 -- AI05-0188 : Within an instance the non-others choices do not
1359 -- have to belong to the actual subtype.
1360
1361 elsif Ada_Version >= Ada_2012 and then In_Instance then
1362 return;
1363
1364 -- Otherwise we have an OK static choice
1365
1366 else
1367 Lo_Val := Expr_Value (Lo);
1368 Hi_Val := Expr_Value (Hi);
1369
1370 -- Do not insert null ranges in the choices table
1371
1372 if Lo_Val > Hi_Val then
1373 Process_Empty_Choice (Choice);
1374 return;
1375 end if;
1376 end if;
1377
1378 -- Check for low bound out of range
1379
1380 if Lo_Val < Bounds_Lo then
1381
1382 -- If the choice is an entity name, then it is a type, and we
1383 -- want to post the message on the reference to this entity.
1384 -- Otherwise post it on the lower bound of the range.
1385
1386 if Is_Entity_Name (Choice) then
1387 Enode := Choice;
1388 else
1389 Enode := Lo;
1390 end if;
1391
1392 -- Specialize message for integer/enum type
1393
1394 if Is_Integer_Type (Bounds_Type) then
1395 Error_Msg_Uint_1 := Bounds_Lo;
1396 Error_Msg_N ("minimum allowed choice value is^", Enode);
1397 else
1398 Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
1399 Error_Msg_N ("minimum allowed choice value is%", Enode);
1400 end if;
1401 end if;
1402
1403 -- Check for high bound out of range
1404
1405 if Hi_Val > Bounds_Hi then
1406
1407 -- If the choice is an entity name, then it is a type, and we
1408 -- want to post the message on the reference to this entity.
1409 -- Otherwise post it on the upper bound of the range.
1410
1411 if Is_Entity_Name (Choice) then
1412 Enode := Choice;
1413 else
1414 Enode := Hi;
1415 end if;
1416
1417 -- Specialize message for integer/enum type
1418
1419 if Is_Integer_Type (Bounds_Type) then
1420 Error_Msg_Uint_1 := Bounds_Hi;
1421 Error_Msg_N ("maximum allowed choice value is^", Enode);
1422 else
1423 Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
1424 Error_Msg_N ("maximum allowed choice value is%", Enode);
1425 end if;
1426 end if;
1427
1428 -- Collect bounds in the list
1429
1430 -- Note: we still store the bounds, even if they are out of range,
1431 -- since this may prevent unnecessary cascaded errors for values
1432 -- that are covered by such an excessive range.
1433
1434 Choice_List :=
1435 new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1436 Num_Choices := Num_Choices + 1;
1437 end Check;
1438
1439 -- Start of processing for Check_Choices
1440
1441 begin
1442 Raises_CE := False;
1443 Others_Present := False;
1444
1445 -- If Subtyp is not a discrete type or there was some other error,
1446 -- then don't try any semantic checking on the choices since we have
1447 -- a complete mess.
1448
1449 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
1450 return;
1451 end if;
1452
1453 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1454 -- bounds of its base type to determine the values covered by the
1455 -- discrete choices.
1456
1457 -- In Ada 2012, if the subtype has a non-static predicate the full
1458 -- range of the base type must be covered as well.
1459
1460 if Is_OK_Static_Subtype (Subtyp) then
1461 if not Has_Predicates (Subtyp)
1462 or else Has_Static_Predicate (Subtyp)
1463 then
1464 Bounds_Type := Subtyp;
1465 else
1466 Bounds_Type := Choice_Type;
1467 end if;
1468
1469 else
1470 Bounds_Type := Choice_Type;
1471 end if;
1472
1473 -- Obtain static bounds of type, unless this is a generic formal
1474 -- discrete type for which all choices will be non-static.
1475
1476 if not Is_Generic_Type (Root_Type (Bounds_Type))
1477 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1478 then
1479 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1480 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1481 end if;
1482
1483 if Choice_Type = Universal_Integer then
1484 Expected_Type := Any_Integer;
1485 else
1486 Expected_Type := Choice_Type;
1487 end if;
1488
1489 -- Now loop through the case alternatives or record variants
1490
1491 Alt := First (Alternatives);
1492 while Present (Alt) loop
1493
1494 -- If pragma, just analyze it
1495
1496 if Nkind (Alt) = N_Pragma then
1497 Analyze (Alt);
1498
1499 -- Otherwise we have an alternative. In most cases the semantic
1500 -- processing leaves the list of choices unchanged
1501
1502 -- Check each choice against its base type
1503
1504 else
1505 Choice := First (Discrete_Choices (Alt));
1506 while Present (Choice) loop
1507 Kind := Nkind (Choice);
1508
1509 -- Choice is a Range
1510
1511 if Kind = N_Range
1512 or else (Kind = N_Attribute_Reference
1513 and then Attribute_Name (Choice) = Name_Range)
1514 then
1515 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1516
1517 -- Choice is a subtype name
1518
1519 elsif Is_Entity_Name (Choice)
1520 and then Is_Type (Entity (Choice))
1521 then
1522 -- Check for inappropriate type
1523
1524 if not Covers (Expected_Type, Etype (Choice)) then
1525 Wrong_Type (Choice, Choice_Type);
1526
1527 -- Type is OK, so check further
1528
1529 else
1530 E := Entity (Choice);
1531
1532 -- Case of predicated subtype
1533
1534 if Has_Predicates (E) then
1535
1536 -- Use of non-static predicate is an error
1537
1538 if not Is_Discrete_Type (E)
1539 or else not Has_Static_Predicate (E)
1540 or else Has_Dynamic_Predicate_Aspect (E)
1541 then
1542 Bad_Predicated_Subtype_Use
1543 ("cannot use subtype& with non-static "
1544 & "predicate as case alternative",
1545 Choice, E, Suggest_Static => True);
1546
1547 -- Static predicate case
1548
1549 else
1550 declare
1551 P : Node_Id;
1552 C : Node_Id;
1553
1554 begin
1555 -- Loop through entries in predicate list,
1556 -- checking each entry. Note that if the
1557 -- list is empty, corresponding to a False
1558 -- predicate, then no choices are checked.
1559
1560 P := First (Static_Discrete_Predicate (E));
1561 while Present (P) loop
1562 C := New_Copy (P);
1563 Set_Sloc (C, Sloc (Choice));
1564 Check (C, Low_Bound (C), High_Bound (C));
1565 Next (P);
1566 end loop;
1567 end;
1568
1569 Set_Has_SP_Choice (Alt);
1570 end if;
1571
1572 -- Not predicated subtype case
1573
1574 elsif not Is_OK_Static_Subtype (E) then
1575 Process_Non_Static_Choice (Choice);
1576 else
1577 Check
1578 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1579 end if;
1580 end if;
1581
1582 -- Choice is a subtype indication
1583
1584 elsif Kind = N_Subtype_Indication then
1585 Resolve_Discrete_Subtype_Indication
1586 (Choice, Expected_Type);
1587
1588 if Etype (Choice) /= Any_Type then
1589 declare
1590 C : constant Node_Id := Constraint (Choice);
1591 R : constant Node_Id := Range_Expression (C);
1592 L : constant Node_Id := Low_Bound (R);
1593 H : constant Node_Id := High_Bound (R);
1594
1595 begin
1596 E := Entity (Subtype_Mark (Choice));
1597
1598 if not Is_OK_Static_Subtype (E) then
1599 Process_Non_Static_Choice (Choice);
1600
1601 else
1602 if Is_OK_Static_Expression (L)
1603 and then
1604 Is_OK_Static_Expression (H)
1605 then
1606 if Expr_Value (L) > Expr_Value (H) then
1607 Process_Empty_Choice (Choice);
1608 else
1609 if Is_Out_Of_Range (L, E) then
1610 Apply_Compile_Time_Constraint_Error
1611 (L, "static value out of range",
1612 CE_Range_Check_Failed);
1613 end if;
1614
1615 if Is_Out_Of_Range (H, E) then
1616 Apply_Compile_Time_Constraint_Error
1617 (H, "static value out of range",
1618 CE_Range_Check_Failed);
1619 end if;
1620 end if;
1621 end if;
1622
1623 Check (Choice, L, H);
1624 end if;
1625 end;
1626 end if;
1627
1628 -- The others choice is only allowed for the last
1629 -- alternative and as its only choice.
1630
1631 elsif Kind = N_Others_Choice then
1632 if not (Choice = First (Discrete_Choices (Alt))
1633 and then Choice = Last (Discrete_Choices (Alt))
1634 and then Alt = Last (Alternatives))
1635 then
1636 Error_Msg_N
1637 ("the choice OTHERS must appear alone and last",
1638 Choice);
1639 return;
1640 end if;
1641
1642 Others_Present := True;
1643 Others_Choice := Choice;
1644
1645 -- Only other possibility is an expression
1646
1647 else
1648 Check (Choice, Choice, Choice);
1649 end if;
1650
1651 -- Move to next choice
1652
1653 Next (Choice);
1654 end loop;
1655
1656 Process_Associated_Node (Alt);
1657 end if;
1658
1659 Next (Alt);
1660 end loop;
1661
1662 -- Now we can create the Choice_Table, since we know how long
1663 -- it needs to be so we can allocate exactly the right length.
1664
1665 declare
1666 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1667
1668 begin
1669 -- Now copy the items we collected in the linked list into this
1670 -- newly allocated table (leave entry 0 unused for sorting).
1671
1672 declare
1673 T : Link_Ptr;
1674 begin
1675 for J in 1 .. Num_Choices loop
1676 T := Choice_List;
1677 Choice_List := T.Nxt;
1678 Choice_Table (J) := T.Val;
1679 Free (T);
1680 end loop;
1681 end;
1682
1683 Check_Choice_Set
1684 (Choice_Table,
1685 Bounds_Type,
1686 Subtyp,
1687 Others_Present or else (Choice_Type = Universal_Integer),
1688 N);
1689
1690 -- If no others choice we are all done, otherwise we have one more
1691 -- step, which is to set the Others_Discrete_Choices field of the
1692 -- others choice (to contain all otherwise unspecified choices).
1693 -- Skip this if CE is known to be raised.
1694
1695 if Others_Present and not Raises_CE then
1696 Expand_Others_Choice
1697 (Case_Table => Choice_Table,
1698 Others_Choice => Others_Choice,
1699 Choice_Type => Bounds_Type);
1700 end if;
1701 end;
1702 end Check_Choices;
1703
1704 end Generic_Check_Choices;
1705
1706 end Sem_Case;
Mirror of the offical gcc git repository hosted at gcc.gnu.org