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