1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
;
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
;
45 with Ada
.Unchecked_Deallocation
;
47 with GNAT
.Heap_Sort_G
;
49 package body Sem_Case
is
51 type Choice_Bounds
is record
56 -- Represent one choice bounds entry with Lo and Hi values, Node points
57 -- to the choice node itself.
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.
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 procedure Check_Choice_Set
69 (Choice_Table
: in out Choice_Table_Type
;
70 Bounds_Type
: Entity_Id
;
72 Others_Present
: Boolean;
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.
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.
85 -- Bounds_Type is the type whose range must be covered by the alternatives
87 -- Subtyp is the subtype of the expression. If its bounds are non-static
88 -- the alternatives must cover its base type.
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.
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.
106 ----------------------
107 -- Check_Choice_Set --
108 ----------------------
110 procedure Check_Choice_Set
111 (Choice_Table
: in out Choice_Table_Type
;
112 Bounds_Type
: Entity_Id
;
114 Others_Present
: Boolean;
117 Predicate_Error
: Boolean := False;
118 -- Flag to prevent cascaded errors when a static predicate is known to
119 -- be violated by one choice.
121 Num_Choices
: constant Nat
:= Choice_Table
'Last;
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.
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.
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.
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.
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.
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.
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.
164 procedure Move_Choice
(From
: Natural; To
: Natural);
165 -- Move routine for sorting the Choice_Table
167 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
169 -----------------------------
170 -- Check_Against_Predicate --
171 -----------------------------
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)
180 procedure Illegal_Range
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.
188 function Inside_Range
191 Val
: Uint
) return Boolean;
192 -- Determine whether position Val within a discrete type is within
193 -- the range Lo .. Hi inclusive.
199 procedure Illegal_Range
205 Error_Msg_Name_1
:= Chars
(Bounds_Type
);
210 if Is_Integer_Type
(Bounds_Type
) then
211 Error_Msg_Uint_1
:= Lo
;
212 Error_Msg
("static predicate on % excludes value ^!", Loc
);
214 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
215 Error_Msg
("static predicate on % excludes value %!", Loc
);
221 if Is_Integer_Type
(Bounds_Type
) then
222 Error_Msg_Uint_1
:= Lo
;
223 Error_Msg_Uint_2
:= Hi
;
225 ("static predicate on % excludes range ^ .. ^!", Loc
);
227 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
228 Error_Msg_Name_3
:= Choice_Image
(Hi
, Bounds_Type
);
230 ("static predicate on % excludes range % .. %!", Loc
);
239 function Inside_Range
242 Val
: Uint
) return Boolean
245 return Lo
<= Val
and then Val
<= Hi
;
250 Choice_Hi
: constant Uint
:= Expr_Value
(Choice
.Hi
);
251 Choice_Lo
: constant Uint
:= Expr_Value
(Choice
.Lo
);
259 -- Start of processing for Check_Against_Predicate
262 -- Find the proper error message location
264 if Present
(Choice
.Node
) then
272 if Present
(Pred
) then
273 Pred_Lo
:= Expr_Value
(Low_Bound
(Pred
));
274 Pred_Hi
:= Expr_Value
(High_Bound
(Pred
));
276 -- Previous choices managed to satisfy all static predicate sets
279 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
284 -- Step 1: Ignore duplicate choices, other than to set the flag,
285 -- because these were already detected by Check_Duplicates.
287 if Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Lo
)
288 or else Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Hi
)
292 -- Step 2: Detect full coverage
294 -- Choice_Lo Choice_Hi
298 elsif Choice_Lo
= Pred_Lo
and then Choice_Hi
= Pred_Hi
then
299 Prev_Lo
:= Choice_Lo
;
300 Prev_Hi
:= Choice_Hi
;
303 -- Step 3: Detect all cases where a choice mentions values that are
304 -- not part of the static predicate sets.
306 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
307 -- +-----------+ . . . . . +=========+
310 elsif Choice_Lo
< Pred_Lo
and then Choice_Hi
< Pred_Lo
then
311 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
314 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
315 -- +-----------+=========+===========+
318 elsif Choice_Lo
< Pred_Lo
319 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Hi
)
321 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
324 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
325 -- +=========+ . . . . +-----------+
328 elsif Pred_Lo
< Choice_Lo
and then Pred_Hi
< Choice_Lo
then
329 if Others_Present
then
331 -- Current predicate set is covered by others clause.
336 Missing_Choice
(Pred_Lo
, Pred_Hi
);
340 -- There may be several static predicate sets between the current
341 -- one and the choice. Inspect the next static predicate set.
344 Check_Against_Predicate
351 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
352 -- +=========+===========+-----------+
355 elsif Pred_Hi
< Choice_Hi
356 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Lo
)
360 -- The choice may fall in a static predicate set. If this is the
361 -- case, avoid mentioning legal values in the error message.
363 if Present
(Pred
) then
364 Next_Lo
:= Expr_Value
(Low_Bound
(Pred
));
365 Next_Hi
:= Expr_Value
(High_Bound
(Pred
));
367 -- The next static predicate set is to the right of the choice
369 if Choice_Hi
< Next_Lo
and then Choice_Hi
< Next_Hi
then
370 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
372 Illegal_Range
(Loc
, Pred_Hi
+ 1, Next_Lo
- 1);
375 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
380 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
381 -- +-----------+=========+-----------+
382 -- ^ illegal ^ ^ illegal ^
384 -- Emit an error on the low gap, disregard the upper gap
386 elsif Choice_Lo
< Pred_Lo
and then Pred_Hi
< Choice_Hi
then
387 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
390 -- Step 4: Detect all cases of partial or missing coverage
392 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
393 -- +=========+==========+===========+
397 -- An "others" choice covers all gaps
399 if Others_Present
then
400 Prev_Lo
:= Choice_Lo
;
401 Prev_Hi
:= Choice_Hi
;
403 -- Check whether predicate set is fully covered by choice
405 if Pred_Hi
= Choice_Hi
then
409 -- Choice_Lo Choice_Hi Pred_Hi
410 -- +===========+===========+
413 -- The upper gap may be covered by a subsequent choice
415 elsif Pred_Lo
= Choice_Lo
then
416 Prev_Lo
:= Choice_Lo
;
417 Prev_Hi
:= Choice_Hi
;
419 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
420 -- +===========+=========+===========+===========+
421 -- ^ covered ^ ^ gap ^
423 else pragma Assert
(Pred_Lo
< Choice_Lo
);
425 -- A previous choice covered the gap up to the current choice
427 if Prev_Hi
= Choice_Lo
- 1 then
428 Prev_Lo
:= Choice_Lo
;
429 Prev_Hi
:= Choice_Hi
;
431 if Choice_Hi
= Pred_Hi
then
435 -- The previous choice did not intersect with the current
436 -- static predicate set.
438 elsif Prev_Hi
< Pred_Lo
then
439 Missing_Choice
(Pred_Lo
, Choice_Lo
- 1);
442 -- The previous choice covered part of the static predicate set
443 -- but there is a gap after Prev_Hi.
446 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
451 end Check_Against_Predicate
;
453 ----------------------
454 -- Check_Duplicates --
455 ----------------------
457 procedure Check_Duplicates
is
461 Prev_Choice
: Node_Id
;
465 Prev_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
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
);
471 -- Choices overlap; this is an error
473 if Choice_Lo
<= Prev_Hi
then
474 Choice
:= Choice_Table
(Outer_Index
).Node
;
476 -- Find first previous choice that overlaps
478 for Inner_Index
in 1 .. Outer_Index
- 1 loop
480 Expr_Value
(Choice_Table
(Inner_Index
).Hi
)
482 Prev_Choice
:= Choice_Table
(Inner_Index
).Node
;
487 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
488 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
489 Dup_Choice
(Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Choice
);
491 Error_Msg_Sloc
:= Sloc
(Choice
);
493 (Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Prev_Choice
);
497 if Choice_Hi
> Prev_Hi
then
498 Prev_Hi
:= Choice_Hi
;
501 end Check_Duplicates
;
507 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
) is
509 -- In some situations, we call this with a null range, and obviously
510 -- we don't want to complain in this case.
516 -- Case of only one value that is duplicated
522 if Is_Integer_Type
(Bounds_Type
) then
524 -- We have an integer value, Lo, but if the given choice
525 -- placement is a constant with that value, then use the
526 -- name of that constant instead in the message:
528 if Nkind
(C
) = N_Identifier
529 and then Compile_Time_Known_Value
(C
)
530 and then Expr_Value
(C
) = Lo
532 Error_Msg_N
("duplication of choice value: &#!", C
);
534 -- Not that special case, so just output the integer value
537 Error_Msg_Uint_1
:= Lo
;
538 Error_Msg_N
("duplication of choice value: ^#!", C
);
544 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
545 Error_Msg_N
("duplication of choice value: %#!", C
);
548 -- More than one choice value, so print range of values
553 if Is_Integer_Type
(Bounds_Type
) then
555 -- Similar to the above, if C is a range of known values which
556 -- match Lo and Hi, then use the names. We have to go to the
557 -- original nodes, since the values will have been rewritten
558 -- to their integer values.
560 if Nkind
(C
) = N_Range
561 and then Nkind
(Original_Node
(Low_Bound
(C
))) = N_Identifier
562 and then Nkind
(Original_Node
(High_Bound
(C
))) = N_Identifier
563 and then Compile_Time_Known_Value
(Low_Bound
(C
))
564 and then Compile_Time_Known_Value
(High_Bound
(C
))
565 and then Expr_Value
(Low_Bound
(C
)) = Lo
566 and then Expr_Value
(High_Bound
(C
)) = Hi
568 Error_Msg_Node_2
:= Original_Node
(High_Bound
(C
));
570 ("duplication of choice values: & .. &#!",
571 Original_Node
(Low_Bound
(C
)));
573 -- Not that special case, output integer values
576 Error_Msg_Uint_1
:= Lo
;
577 Error_Msg_Uint_2
:= Hi
;
578 Error_Msg_N
("duplication of choice values: ^ .. ^#!", C
);
584 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
585 Error_Msg_Name_2
:= Choice_Image
(Hi
, Bounds_Type
);
586 Error_Msg_N
("duplication of choice values: % .. %#!", C
);
591 ------------------------------
592 -- Explain_Non_Static_Bound --
593 ------------------------------
595 procedure Explain_Non_Static_Bound
is
599 if Nkind
(Case_Node
) = N_Variant_Part
then
600 Expr
:= Name
(Case_Node
);
602 Expr
:= Expression
(Case_Node
);
605 if Bounds_Type
/= Subtyp
then
607 -- If the case is a variant part, the expression is given by the
608 -- discriminant itself, and the bounds are the culprits.
610 if Nkind
(Case_Node
) = N_Variant_Part
then
612 ("bounds of & are not static, "
613 & "alternatives must cover base type!", Expr
, Expr
);
615 -- If this is a case statement, the expression may be non-static
616 -- or else the subtype may be at fault.
618 elsif Is_Entity_Name
(Expr
) then
620 ("bounds of & are not static, "
621 & "alternatives must cover base type!", Expr
, Expr
);
625 ("subtype of expression is not static, "
626 & "alternatives must cover base type!", Expr
);
629 -- Otherwise the expression is not static, even if the bounds of the
630 -- type are, or else there are missing alternatives. If both, the
631 -- additional information may be redundant but harmless. Examine
632 -- whether original node is an entity, because it may have been
633 -- constant-folded to a literal if value is known.
635 elsif not Is_Entity_Name
(Original_Node
(Expr
)) then
637 ("subtype of expression is not static, "
638 & "alternatives must cover base type!", Expr
);
640 end Explain_Non_Static_Bound
;
646 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
649 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
651 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
658 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
) is
660 Missing_Choice
(Expr_Value
(Value1
), Expr_Value
(Value2
));
663 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
) is
665 Missing_Choice
(Expr_Value
(Value1
), Value2
);
668 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
) is
670 Missing_Choice
(Value1
, Expr_Value
(Value2
));
677 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
) is
678 Msg_Sloc
: constant Source_Ptr
:= Sloc
(Case_Node
);
681 -- AI05-0188 : within an instance the non-others choices do not have
682 -- to belong to the actual subtype.
684 if Ada_Version
>= Ada_2012
and then In_Instance
then
687 -- In some situations, we call this with a null range, and obviously
688 -- we don't want to complain in this case.
690 elsif Value1
> Value2
then
693 -- If predicate is already known to be violated, do no check for
694 -- coverage error, to prevent cascaded messages.
696 elsif Predicate_Error
then
700 -- Case of only one value that is missing
702 if Value1
= Value2
then
703 if Is_Integer_Type
(Bounds_Type
) then
704 Error_Msg_Uint_1
:= Value1
;
705 Error_Msg
("missing case value: ^!", Msg_Sloc
);
707 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
708 Error_Msg
("missing case value: %!", Msg_Sloc
);
711 -- More than one choice value, so print range of values
714 if Is_Integer_Type
(Bounds_Type
) then
715 Error_Msg_Uint_1
:= Value1
;
716 Error_Msg_Uint_2
:= Value2
;
717 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
719 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
720 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
721 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
726 ---------------------
727 -- Missing_Choices --
728 ---------------------
730 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
) is
737 while Present
(Set
) loop
738 Lo
:= Expr_Value
(Low_Bound
(Set
));
739 Hi
:= Expr_Value
(High_Bound
(Set
));
741 -- A choice covered part of a static predicate set
743 if Lo
<= Prev_Hi
and then Prev_Hi
< Hi
then
744 Missing_Choice
(Prev_Hi
+ 1, Hi
);
747 Missing_Choice
(Lo
, Hi
);
758 procedure Move_Choice
(From
: Natural; To
: Natural) is
760 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
765 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
766 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
767 Has_Predicate
: constant Boolean :=
768 Is_OK_Static_Subtype
(Bounds_Type
)
769 and then Has_Static_Predicate
(Bounds_Type
);
777 -- Start of processing for Check_Choice_Set
780 -- If the case is part of a predicate aspect specification, do not
781 -- recheck it against itself.
783 if Present
(Parent
(Case_Node
))
784 and then Nkind
(Parent
(Case_Node
)) = N_Aspect_Specification
789 -- Choice_Table must start at 0 which is an unused location used by the
790 -- sorting algorithm. However the first valid position for a discrete
793 pragma Assert
(Choice_Table
'First = 0);
795 -- The choices do not cover the base range. Emit an error if "others" is
796 -- not available and return as there is no need for further processing.
798 if Num_Choices
= 0 then
799 if not Others_Present
then
800 Missing_Choice
(Bounds_Lo
, Bounds_Hi
);
806 Sorting
.Sort
(Positive (Choice_Table
'Last));
808 -- First check for duplicates. This involved the choices; predicates, if
809 -- any, are irrelevant.
813 -- Then check for overlaps
815 -- If the subtype has a static predicate, the predicate defines subsets
816 -- of legal values and requires finer-grained analysis.
818 -- Note that in GNAT the predicate is considered static if the predicate
819 -- expression is static, independently of whether the aspect mentions
820 -- Static explicitly.
822 if Has_Predicate
then
823 Pred
:= First
(Static_Discrete_Predicate
(Bounds_Type
));
825 -- Make initial value smaller than 'First of type, so that first
826 -- range comparison succeeds. This applies both to integer types
827 -- and to enumeration types.
829 Prev_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
)) - 1;
833 Error
: Boolean := False;
835 for Index
in 1 .. Num_Choices
loop
836 Check_Against_Predicate
838 Choice
=> Choice_Table
(Index
),
843 -- The analysis detected an illegal intersection between a
844 -- choice and a static predicate set. Do not examine other
845 -- choices unless all errors are requested.
848 Predicate_Error
:= True;
850 if not All_Errors_Mode
then
857 if Predicate_Error
then
861 -- The choices may legally cover some of the static predicate sets,
862 -- but not all. Emit an error for each non-covered set.
864 if not Others_Present
then
865 Missing_Choices
(Pred
, Prev_Hi
);
871 Choice_Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
872 Choice_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
873 Prev_Hi
:= Choice_Hi
;
875 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Choice_Lo
then
876 Missing_Choice
(Bounds_Lo
, Choice_Lo
- 1);
878 -- If values are missing outside of the subtype, add explanation.
879 -- No additional message if only one value is missing.
881 if Expr_Value
(Bounds_Lo
) < Choice_Lo
- 1 then
882 Explain_Non_Static_Bound
;
886 for Index
in 2 .. Num_Choices
loop
887 Choice_Lo
:= Expr_Value
(Choice_Table
(Index
).Lo
);
888 Choice_Hi
:= Expr_Value
(Choice_Table
(Index
).Hi
);
890 if Choice_Lo
> Prev_Hi
+ 1 and then not Others_Present
then
891 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
894 if Choice_Hi
> Prev_Hi
then
895 Prev_Hi
:= Choice_Hi
;
899 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Prev_Hi
then
900 Missing_Choice
(Prev_Hi
+ 1, Bounds_Hi
);
902 if Expr_Value
(Bounds_Hi
) > Prev_Hi
+ 1 then
903 Explain_Non_Static_Bound
;
907 end Check_Choice_Set
;
913 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
914 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
919 -- For character, or wide [wide] character. If 7-bit ASCII graphic
920 -- range, then build and return appropriate character literal name
922 if Is_Standard_Character_Type
(Ctype
) then
923 C
:= UI_To_Int
(Value
);
925 if C
in 16#
20#
.. 16#
7E#
then
926 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
930 -- For user defined enumeration type, find enum/char literal
933 Lit
:= First_Literal
(Rtp
);
935 for J
in 1 .. UI_To_Int
(Value
) loop
939 -- If enumeration literal, just return its value
941 if Nkind
(Lit
) = N_Defining_Identifier
then
944 -- For character literal, get the name and use it if it is
945 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
948 Get_Decoded_Name_String
(Chars
(Lit
));
951 and then Name_Buffer
(2) in
952 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
959 -- If we fall through, we have a character literal which is not in
960 -- the 7-bit ASCII graphic set. For such cases, we construct the
961 -- name "type'val(nnn)" where type is the choice type, and nnn is
962 -- the pos value passed as an argument to Choice_Image.
964 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
966 Add_Str_To_Name_Buffer
("'val(");
968 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
969 Add_Char_To_Name_Buffer
(')');
973 --------------------------
974 -- Expand_Others_Choice --
975 --------------------------
977 procedure Expand_Others_Choice
978 (Case_Table
: Choice_Table_Type
;
979 Others_Choice
: Node_Id
;
980 Choice_Type
: Entity_Id
)
982 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
983 Choice_List
: constant List_Id
:= New_List
;
991 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
992 -- Builds a node representing the missing choices given by Value1 and
993 -- Value2. A N_Range node is built if there is more than one literal
994 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
995 -- or N_Character_Literal is built depending on what Choice_Type is.
997 function Lit_Of
(Value
: Uint
) return Node_Id
;
998 -- Returns the Node_Id for the enumeration literal corresponding to the
999 -- position given by Value within the enumeration type Choice_Type.
1005 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
1010 -- If there is only one choice value missing between Value1 and
1011 -- Value2, build an integer or enumeration literal to represent it.
1013 if (Value2
- Value1
) = 0 then
1014 if Is_Integer_Type
(Choice_Type
) then
1015 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
1016 Set_Etype
(Lit_Node
, Choice_Type
);
1018 Lit_Node
:= Lit_Of
(Value1
);
1021 -- Otherwise is more that one choice value that is missing between
1022 -- Value1 and Value2, therefore build a N_Range node of either
1023 -- integer or enumeration literals.
1026 if Is_Integer_Type
(Choice_Type
) then
1027 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
1028 Set_Etype
(Lo
, Choice_Type
);
1029 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
1030 Set_Etype
(Hi
, Choice_Type
);
1039 Low_Bound
=> Lit_Of
(Value1
),
1040 High_Bound
=> Lit_Of
(Value2
));
1051 function Lit_Of
(Value
: Uint
) return Node_Id
is
1055 -- In the case where the literal is of type Character, there needs
1056 -- to be some special handling since there is no explicit chain
1057 -- of literals to search. Instead, a N_Character_Literal node
1058 -- is created with the appropriate Char_Code and Chars fields.
1060 if Is_Standard_Character_Type
(Choice_Type
) then
1061 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
1062 Lit
:= New_Node
(N_Character_Literal
, Loc
);
1063 Set_Chars
(Lit
, Name_Find
);
1064 Set_Char_Literal_Value
(Lit
, Value
);
1065 Set_Etype
(Lit
, Choice_Type
);
1066 Set_Is_Static_Expression
(Lit
, True);
1069 -- Otherwise, iterate through the literals list of Choice_Type
1070 -- "Value" number of times until the desired literal is reached
1071 -- and then return an occurrence of it.
1074 Lit
:= First_Literal
(Choice_Type
);
1075 for J
in 1 .. UI_To_Int
(Value
) loop
1079 return New_Occurrence_Of
(Lit
, Loc
);
1083 -- Start of processing for Expand_Others_Choice
1086 if Case_Table
'Last = 0 then
1088 -- Special case: only an others case is present. The others case
1089 -- covers the full range of the type.
1091 if Is_OK_Static_Subtype
(Choice_Type
) then
1092 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
1094 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
1097 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
1101 -- Establish the bound values for the choice depending upon whether the
1102 -- type of the case statement is static or not.
1104 if Is_OK_Static_Subtype
(Choice_Type
) then
1105 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
1106 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
1108 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
1109 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
1112 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
1113 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
1114 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
1116 -- Build the node for any missing choices that are smaller than any
1117 -- explicit choices given in the case.
1119 if Expr_Value
(Exp_Lo
) < Lo
then
1120 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
1123 -- Build the nodes representing any missing choices that lie between
1124 -- the explicit ones given in the case.
1126 for J
in 2 .. Case_Table
'Last loop
1127 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
1128 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
1130 if Lo
/= (Previous_Hi
+ 1) then
1131 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
1137 -- Build the node for any missing choices that are greater than any
1138 -- explicit choices given in the case.
1140 if Expr_Value
(Exp_Hi
) > Hi
then
1141 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
1144 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
1146 -- Warn on null others list if warning option set
1148 if Warn_On_Redundant_Constructs
1149 and then Comes_From_Source
(Others_Choice
)
1150 and then Is_Empty_List
(Choice_List
)
1152 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
1153 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
1155 end Expand_Others_Choice
;
1161 procedure No_OP
(C
: Node_Id
) is
1163 if Nkind
(C
) = N_Range
and then Warn_On_Redundant_Constructs
then
1164 Error_Msg_N
("choice is an empty range?r?", C
);
1168 -----------------------------
1169 -- Generic_Analyze_Choices --
1170 -----------------------------
1172 package body Generic_Analyze_Choices
is
1174 -- The following type is used to gather the entries for the choice
1175 -- table, so that we can then allocate the right length.
1178 type Link_Ptr
is access all Link
;
1181 Val
: Choice_Bounds
;
1185 ---------------------
1186 -- Analyze_Choices --
1187 ---------------------
1189 procedure Analyze_Choices
1190 (Alternatives
: List_Id
;
1193 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1194 -- The actual type against which the discrete choices are resolved.
1195 -- Note that this type is always the base type not the subtype of the
1196 -- ruling expression, index or discriminant.
1198 Expected_Type
: Entity_Id
;
1199 -- The expected type of each choice. Equal to Choice_Type, except if
1200 -- the expression is universal, in which case the choices can be of
1201 -- any integer type.
1204 -- A case statement alternative or a variant in a record type
1209 -- The node kind of the current Choice
1212 -- Set Expected type (= choice type except for universal integer,
1213 -- where we accept any integer type as a choice).
1215 if Choice_Type
= Universal_Integer
then
1216 Expected_Type
:= Any_Integer
;
1218 Expected_Type
:= Choice_Type
;
1221 -- Now loop through the case alternatives or record variants
1223 Alt
:= First
(Alternatives
);
1224 while Present
(Alt
) loop
1226 -- If pragma, just analyze it
1228 if Nkind
(Alt
) = N_Pragma
then
1231 -- Otherwise we have an alternative. In most cases the semantic
1232 -- processing leaves the list of choices unchanged
1234 -- Check each choice against its base type
1237 Choice
:= First
(Discrete_Choices
(Alt
));
1238 while Present
(Choice
) loop
1240 Kind
:= Nkind
(Choice
);
1242 -- Choice is a Range
1245 or else (Kind
= N_Attribute_Reference
1246 and then Attribute_Name
(Choice
) = Name_Range
)
1248 Resolve
(Choice
, Expected_Type
);
1250 -- Choice is a subtype name, nothing further to do now
1252 elsif Is_Entity_Name
(Choice
)
1253 and then Is_Type
(Entity
(Choice
))
1257 -- Choice is a subtype indication
1259 elsif Kind
= N_Subtype_Indication
then
1260 Resolve_Discrete_Subtype_Indication
1261 (Choice
, Expected_Type
);
1263 -- Others choice, no analysis needed
1265 elsif Kind
= N_Others_Choice
then
1268 -- Only other possibility is an expression
1271 Resolve
(Choice
, Expected_Type
);
1274 -- Move to next choice
1279 Process_Associated_Node
(Alt
);
1284 end Analyze_Choices
;
1286 end Generic_Analyze_Choices
;
1288 ---------------------------
1289 -- Generic_Check_Choices --
1290 ---------------------------
1292 package body Generic_Check_Choices
is
1294 -- The following type is used to gather the entries for the choice
1295 -- table, so that we can then allocate the right length.
1298 type Link_Ptr
is access all Link
;
1301 Val
: Choice_Bounds
;
1305 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
1311 procedure Check_Choices
1313 Alternatives
: List_Id
;
1315 Others_Present
: out Boolean)
1319 Raises_CE
: Boolean;
1320 -- Set True if one of the bounds of a choice raises CE
1323 -- This is where we post error messages for bounds out of range
1325 Choice_List
: Link_Ptr
:= null;
1326 -- Gather list of choices
1328 Num_Choices
: Nat
:= 0;
1329 -- Number of entries in Choice_List
1331 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1332 -- The actual type against which the discrete choices are resolved.
1333 -- Note that this type is always the base type not the subtype of the
1334 -- ruling expression, index or discriminant.
1336 Bounds_Type
: Entity_Id
;
1337 -- The type from which are derived the bounds of the values covered
1338 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1339 -- specifies a value outside of these bounds we have an error.
1343 -- The actual bounds of the above type
1345 Expected_Type
: Entity_Id
;
1346 -- The expected type of each choice. Equal to Choice_Type, except if
1347 -- the expression is universal, in which case the choices can be of
1348 -- any integer type.
1351 -- A case statement alternative or a variant in a record type
1356 -- The node kind of the current Choice
1358 Others_Choice
: Node_Id
:= Empty
;
1359 -- Remember others choice if it is present (empty otherwise)
1361 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
1362 -- Checks the validity of the bounds of a choice. When the bounds
1363 -- are static and no error occurred the bounds are collected for
1364 -- later entry into the choices table so that they can be sorted
1367 procedure Handle_Static_Predicate
1371 -- If the type of the alternative has predicates, we must examine
1372 -- each subset of the predicate rather than the bounds of the type
1373 -- itself. This is relevant when the choice is a subtype mark or a
1374 -- subtype indication.
1380 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
1385 -- First check if an error was already detected on either bounds
1387 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
1390 -- Do not insert non static choices in the table to be sorted
1392 elsif not Is_OK_Static_Expression
(Lo
)
1394 not Is_OK_Static_Expression
(Hi
)
1396 Process_Non_Static_Choice
(Choice
);
1399 -- Ignore range which raise constraint error
1401 elsif Raises_Constraint_Error
(Lo
)
1402 or else Raises_Constraint_Error
(Hi
)
1407 -- AI05-0188 : Within an instance the non-others choices do not
1408 -- have to belong to the actual subtype.
1410 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
1413 -- Otherwise we have an OK static choice
1416 Lo_Val
:= Expr_Value
(Lo
);
1417 Hi_Val
:= Expr_Value
(Hi
);
1419 -- Do not insert null ranges in the choices table
1421 if Lo_Val
> Hi_Val
then
1422 Process_Empty_Choice
(Choice
);
1427 -- Check for low bound out of range
1429 if Lo_Val
< Bounds_Lo
then
1431 -- If the choice is an entity name, then it is a type, and we
1432 -- want to post the message on the reference to this entity.
1433 -- Otherwise post it on the lower bound of the range.
1435 if Is_Entity_Name
(Choice
) then
1441 -- Specialize message for integer/enum type
1443 if Is_Integer_Type
(Bounds_Type
) then
1444 Error_Msg_Uint_1
:= Bounds_Lo
;
1445 Error_Msg_N
("minimum allowed choice value is^", Enode
);
1447 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
1448 Error_Msg_N
("minimum allowed choice value is%", Enode
);
1452 -- Check for high bound out of range
1454 if Hi_Val
> Bounds_Hi
then
1456 -- If the choice is an entity name, then it is a type, and we
1457 -- want to post the message on the reference to this entity.
1458 -- Otherwise post it on the upper bound of the range.
1460 if Is_Entity_Name
(Choice
) then
1466 -- Specialize message for integer/enum type
1468 if Is_Integer_Type
(Bounds_Type
) then
1469 Error_Msg_Uint_1
:= Bounds_Hi
;
1470 Error_Msg_N
("maximum allowed choice value is^", Enode
);
1472 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
1473 Error_Msg_N
("maximum allowed choice value is%", Enode
);
1477 -- Collect bounds in the list
1479 -- Note: we still store the bounds, even if they are out of range,
1480 -- since this may prevent unnecessary cascaded errors for values
1481 -- that are covered by such an excessive range.
1484 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1485 Num_Choices := Num_Choices + 1;
1488 -----------------------------
1489 -- Handle_Static_Predicate --
1490 -----------------------------
1492 procedure Handle_Static_Predicate
1501 -- Loop through entries in predicate list, checking each entry.
1502 -- Note that if the list is empty, corresponding to a False
1503 -- predicate, then no choices are checked. If the choice comes
1504 -- from a subtype indication, the given range may have bounds
1505 -- that narrow the predicate choices themselves, so we must
1506 -- consider only those entries within the range of the given
1507 -- subtype indication..
1509 P := First (Static_Discrete_Predicate (Typ));
1510 while Present (P) loop
1512 -- Check that part of the predicate choice is included in the
1515 if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
1516 and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
1519 Set_Sloc (C, Sloc (Choice));
1521 if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
1522 Set_Low_Bound (C, Lo);
1525 if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
1526 Set_High_Bound (C, Hi);
1529 Check (C, Low_Bound (C), High_Bound (C));
1535 Set_Has_SP_Choice (Alt);
1536 end Handle_Static_Predicate;
1538 -- Start of processing for Check_Choices
1542 Others_Present := False;
1544 -- If Subtyp is not a discrete type or there was some other error,
1545 -- then don't try any semantic checking on the choices since we have
1548 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
1552 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1553 -- bounds of its base type to determine the values covered by the
1554 -- discrete choices.
1556 -- In Ada 2012, if the subtype has a non-static predicate the full
1557 -- range of the base type must be covered as well.
1559 if Is_OK_Static_Subtype (Subtyp) then
1560 if not Has_Predicates (Subtyp)
1561 or else Has_Static_Predicate (Subtyp)
1563 Bounds_Type := Subtyp;
1565 Bounds_Type := Choice_Type;
1569 Bounds_Type := Choice_Type;
1572 -- Obtain static bounds of type, unless this is a generic formal
1573 -- discrete type for which all choices will be non-static.
1575 if not Is_Generic_Type (Root_Type (Bounds_Type))
1576 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1578 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1579 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1582 if Choice_Type = Universal_Integer then
1583 Expected_Type := Any_Integer;
1585 Expected_Type := Choice_Type;
1588 -- Now loop through the case alternatives or record variants
1590 Alt := First (Alternatives);
1591 while Present (Alt) loop
1593 -- If pragma, just analyze it
1595 if Nkind (Alt) = N_Pragma then
1598 -- Otherwise we have an alternative. In most cases the semantic
1599 -- processing leaves the list of choices unchanged
1601 -- Check each choice against its base type
1604 Choice := First (Discrete_Choices (Alt));
1605 while Present (Choice) loop
1606 Kind := Nkind (Choice);
1608 -- Choice is a Range
1611 or else (Kind = N_Attribute_Reference
1612 and then Attribute_Name (Choice) = Name_Range)
1614 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1616 -- Choice is a subtype name
1618 elsif Is_Entity_Name (Choice)
1619 and then Is_Type (Entity (Choice))
1621 -- Check for inappropriate type
1623 if not Covers (Expected_Type, Etype (Choice)) then
1624 Wrong_Type (Choice, Choice_Type);
1626 -- Type is OK, so check further
1629 E := Entity (Choice);
1631 -- Case of predicated subtype
1633 if Has_Predicates (E) then
1635 -- Use of non-static predicate is an error
1637 if not Is_Discrete_Type (E)
1638 or else not Has_Static_Predicate (E)
1639 or else Has_Dynamic_Predicate_Aspect (E)
1641 Bad_Predicated_Subtype_Use
1642 ("cannot use subtype& with non-static "
1643 & "predicate as case alternative",
1644 Choice, E, Suggest_Static => True);
1646 -- Static predicate case. The bounds are those of
1647 -- the given subtype.
1650 Handle_Static_Predicate (E,
1651 Type_Low_Bound (E), Type_High_Bound (E));
1654 -- Not predicated subtype case
1656 elsif not Is_OK_Static_Subtype (E) then
1657 Process_Non_Static_Choice (Choice);
1660 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1664 -- Choice is a subtype indication
1666 elsif Kind = N_Subtype_Indication then
1667 Resolve_Discrete_Subtype_Indication
1668 (Choice, Expected_Type);
1670 if Etype (Choice) /= Any_Type then
1672 C : constant Node_Id := Constraint (Choice);
1673 R : constant Node_Id := Range_Expression (C);
1674 L : constant Node_Id := Low_Bound (R);
1675 H : constant Node_Id := High_Bound (R);
1678 E := Entity (Subtype_Mark (Choice));
1680 if not Is_OK_Static_Subtype (E) then
1681 Process_Non_Static_Choice (Choice);
1684 if Is_OK_Static_Expression (L)
1686 Is_OK_Static_Expression (H)
1688 if Expr_Value (L) > Expr_Value (H) then
1689 Process_Empty_Choice (Choice);
1691 if Is_Out_Of_Range (L, E) then
1692 Apply_Compile_Time_Constraint_Error
1693 (L, "static value out of range",
1694 CE_Range_Check_Failed);
1697 if Is_Out_Of_Range (H, E) then
1698 Apply_Compile_Time_Constraint_Error
1699 (H, "static value out of range",
1700 CE_Range_Check_Failed);
1705 -- Check applicable predicate values within the
1706 -- bounds of the given range.
1708 if Has_Static_Predicate (E) then
1709 Handle_Static_Predicate (E, L, H);
1712 Check (Choice, L, H);
1718 -- The others choice is only allowed for the last
1719 -- alternative and as its only choice.
1721 elsif Kind = N_Others_Choice then
1722 if not (Choice = First (Discrete_Choices (Alt))
1723 and then Choice = Last (Discrete_Choices (Alt))
1724 and then Alt = Last (Alternatives))
1727 ("the choice OTHERS must appear alone and last",
1732 Others_Present := True;
1733 Others_Choice := Choice;
1735 -- Only other possibility is an expression
1738 Check (Choice, Choice, Choice);
1741 -- Move to next choice
1746 Process_Associated_Node (Alt);
1752 -- Now we can create the Choice_Table, since we know how long
1753 -- it needs to be so we can allocate exactly the right length.
1756 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1759 -- Now copy the items we collected in the linked list into this
1760 -- newly allocated table (leave entry 0 unused for sorting).
1765 for J in 1 .. Num_Choices loop
1767 Choice_List := T.Nxt;
1768 Choice_Table (J) := T.Val;
1777 Others_Present or else (Choice_Type = Universal_Integer),
1780 -- If no others choice we are all done, otherwise we have one more
1781 -- step, which is to set the Others_Discrete_Choices field of the
1782 -- others choice (to contain all otherwise unspecified choices).
1783 -- Skip this if CE is known to be raised.
1785 if Others_Present and not Raises_CE then
1786 Expand_Others_Choice
1787 (Case_Table => Choice_Table,
1788 Others_Choice => Others_Choice,
1789 Choice_Type => Bounds_Type);
1794 end Generic_Check_Choices;