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