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.
633 elsif not Is_Entity_Name
(Expr
) then
635 ("subtype of expression is not static, "
636 & "alternatives must cover base type!", Expr
);
638 end Explain_Non_Static_Bound
;
644 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
647 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
649 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
656 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
) is
658 Missing_Choice
(Expr_Value
(Value1
), Expr_Value
(Value2
));
661 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
) is
663 Missing_Choice
(Expr_Value
(Value1
), Value2
);
666 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
) is
668 Missing_Choice
(Value1
, Expr_Value
(Value2
));
675 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
) is
676 Msg_Sloc
: constant Source_Ptr
:= Sloc
(Case_Node
);
679 -- AI05-0188 : within an instance the non-others choices do not have
680 -- to belong to the actual subtype.
682 if Ada_Version
>= Ada_2012
and then In_Instance
then
685 -- In some situations, we call this with a null range, and obviously
686 -- we don't want to complain in this case.
688 elsif Value1
> Value2
then
691 -- If predicate is already known to be violated, do no check for
692 -- coverage error, to prevent cascaded messages.
694 elsif Predicate_Error
then
698 -- Case of only one value that is missing
700 if Value1
= Value2
then
701 if Is_Integer_Type
(Bounds_Type
) then
702 Error_Msg_Uint_1
:= Value1
;
703 Error_Msg
("missing case value: ^!", Msg_Sloc
);
705 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
706 Error_Msg
("missing case value: %!", Msg_Sloc
);
709 -- More than one choice value, so print range of values
712 if Is_Integer_Type
(Bounds_Type
) then
713 Error_Msg_Uint_1
:= Value1
;
714 Error_Msg_Uint_2
:= Value2
;
715 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
717 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
718 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
719 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
724 ---------------------
725 -- Missing_Choices --
726 ---------------------
728 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
) is
735 while Present
(Set
) loop
736 Lo
:= Expr_Value
(Low_Bound
(Set
));
737 Hi
:= Expr_Value
(High_Bound
(Set
));
739 -- A choice covered part of a static predicate set
741 if Lo
<= Prev_Hi
and then Prev_Hi
< Hi
then
742 Missing_Choice
(Prev_Hi
+ 1, Hi
);
745 Missing_Choice
(Lo
, Hi
);
756 procedure Move_Choice
(From
: Natural; To
: Natural) is
758 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
763 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
764 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
765 Has_Predicate
: constant Boolean :=
766 Is_OK_Static_Subtype
(Bounds_Type
)
767 and then Has_Static_Predicate
(Bounds_Type
);
775 -- Start of processing for Check_Choice_Set
778 -- If the case is part of a predicate aspect specification, do not
779 -- recheck it against itself.
781 if Present
(Parent
(Case_Node
))
782 and then Nkind
(Parent
(Case_Node
)) = N_Aspect_Specification
787 -- Choice_Table must start at 0 which is an unused location used by the
788 -- sorting algorithm. However the first valid position for a discrete
791 pragma Assert
(Choice_Table
'First = 0);
793 -- The choices do not cover the base range. Emit an error if "others" is
794 -- not available and return as there is no need for further processing.
796 if Num_Choices
= 0 then
797 if not Others_Present
then
798 Missing_Choice
(Bounds_Lo
, Bounds_Hi
);
804 Sorting
.Sort
(Positive (Choice_Table
'Last));
806 -- First check for duplicates. This involved the choices; predicates, if
807 -- any, are irrelevant.
811 -- Then check for overlaps
813 -- If the subtype has a static predicate, the predicate defines subsets
814 -- of legal values and requires finer-grained analysis.
816 -- Note that in GNAT the predicate is considered static if the predicate
817 -- expression is static, independently of whether the aspect mentions
818 -- Static explicitly.
820 if Has_Predicate
then
821 Pred
:= First
(Static_Discrete_Predicate
(Bounds_Type
));
823 -- Make initial value smaller than 'First of type, so that first
824 -- range comparison succeeds. This applies both to integer types
825 -- and to enumeration types.
827 Prev_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
)) - 1;
831 Error
: Boolean := False;
833 for Index
in 1 .. Num_Choices
loop
834 Check_Against_Predicate
836 Choice
=> Choice_Table
(Index
),
841 -- The analysis detected an illegal intersection between a
842 -- choice and a static predicate set. Do not examine other
843 -- choices unless all errors are requested.
846 Predicate_Error
:= True;
848 if not All_Errors_Mode
then
855 if Predicate_Error
then
859 -- The choices may legally cover some of the static predicate sets,
860 -- but not all. Emit an error for each non-covered set.
862 if not Others_Present
then
863 Missing_Choices
(Pred
, Prev_Hi
);
869 Choice_Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
870 Choice_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
871 Prev_Hi
:= Choice_Hi
;
873 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Choice_Lo
then
874 Missing_Choice
(Bounds_Lo
, Choice_Lo
- 1);
876 -- If values are missing outside of the subtype, add explanation.
877 -- No additional message if only one value is missing.
879 if Expr_Value
(Bounds_Lo
) < Choice_Lo
- 1 then
880 Explain_Non_Static_Bound
;
884 for Index
in 2 .. Num_Choices
loop
885 Choice_Lo
:= Expr_Value
(Choice_Table
(Index
).Lo
);
886 Choice_Hi
:= Expr_Value
(Choice_Table
(Index
).Hi
);
888 if Choice_Lo
> Prev_Hi
+ 1 and then not Others_Present
then
889 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
892 if Choice_Hi
> Prev_Hi
then
893 Prev_Hi
:= Choice_Hi
;
897 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Prev_Hi
then
898 Missing_Choice
(Prev_Hi
+ 1, Bounds_Hi
);
900 if Expr_Value
(Bounds_Hi
) > Prev_Hi
+ 1 then
901 Explain_Non_Static_Bound
;
905 end Check_Choice_Set
;
911 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
912 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
917 -- For character, or wide [wide] character. If 7-bit ASCII graphic
918 -- range, then build and return appropriate character literal name
920 if Is_Standard_Character_Type
(Ctype
) then
921 C
:= UI_To_Int
(Value
);
923 if C
in 16#
20#
.. 16#
7E#
then
924 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
928 -- For user defined enumeration type, find enum/char literal
931 Lit
:= First_Literal
(Rtp
);
933 for J
in 1 .. UI_To_Int
(Value
) loop
937 -- If enumeration literal, just return its value
939 if Nkind
(Lit
) = N_Defining_Identifier
then
942 -- For character literal, get the name and use it if it is
943 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
946 Get_Decoded_Name_String
(Chars
(Lit
));
949 and then Name_Buffer
(2) in
950 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
957 -- If we fall through, we have a character literal which is not in
958 -- the 7-bit ASCII graphic set. For such cases, we construct the
959 -- name "type'val(nnn)" where type is the choice type, and nnn is
960 -- the pos value passed as an argument to Choice_Image.
962 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
964 Add_Str_To_Name_Buffer
("'val(");
966 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
967 Add_Char_To_Name_Buffer
(')');
971 --------------------------
972 -- Expand_Others_Choice --
973 --------------------------
975 procedure Expand_Others_Choice
976 (Case_Table
: Choice_Table_Type
;
977 Others_Choice
: Node_Id
;
978 Choice_Type
: Entity_Id
)
980 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
981 Choice_List
: constant List_Id
:= New_List
;
989 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
990 -- Builds a node representing the missing choices given by Value1 and
991 -- Value2. A N_Range node is built if there is more than one literal
992 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
993 -- or N_Character_Literal is built depending on what Choice_Type is.
995 function Lit_Of
(Value
: Uint
) return Node_Id
;
996 -- Returns the Node_Id for the enumeration literal corresponding to the
997 -- position given by Value within the enumeration type Choice_Type.
1003 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
1008 -- If there is only one choice value missing between Value1 and
1009 -- Value2, build an integer or enumeration literal to represent it.
1011 if (Value2
- Value1
) = 0 then
1012 if Is_Integer_Type
(Choice_Type
) then
1013 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
1014 Set_Etype
(Lit_Node
, Choice_Type
);
1016 Lit_Node
:= Lit_Of
(Value1
);
1019 -- Otherwise is more that one choice value that is missing between
1020 -- Value1 and Value2, therefore build a N_Range node of either
1021 -- integer or enumeration literals.
1024 if Is_Integer_Type
(Choice_Type
) then
1025 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
1026 Set_Etype
(Lo
, Choice_Type
);
1027 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
1028 Set_Etype
(Hi
, Choice_Type
);
1037 Low_Bound
=> Lit_Of
(Value1
),
1038 High_Bound
=> Lit_Of
(Value2
));
1049 function Lit_Of
(Value
: Uint
) return Node_Id
is
1053 -- In the case where the literal is of type Character, there needs
1054 -- to be some special handling since there is no explicit chain
1055 -- of literals to search. Instead, a N_Character_Literal node
1056 -- is created with the appropriate Char_Code and Chars fields.
1058 if Is_Standard_Character_Type
(Choice_Type
) then
1059 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
1060 Lit
:= New_Node
(N_Character_Literal
, Loc
);
1061 Set_Chars
(Lit
, Name_Find
);
1062 Set_Char_Literal_Value
(Lit
, Value
);
1063 Set_Etype
(Lit
, Choice_Type
);
1064 Set_Is_Static_Expression
(Lit
, True);
1067 -- Otherwise, iterate through the literals list of Choice_Type
1068 -- "Value" number of times until the desired literal is reached
1069 -- and then return an occurrence of it.
1072 Lit
:= First_Literal
(Choice_Type
);
1073 for J
in 1 .. UI_To_Int
(Value
) loop
1077 return New_Occurrence_Of
(Lit
, Loc
);
1081 -- Start of processing for Expand_Others_Choice
1084 if Case_Table
'Last = 0 then
1086 -- Special case: only an others case is present. The others case
1087 -- covers the full range of the type.
1089 if Is_OK_Static_Subtype
(Choice_Type
) then
1090 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
1092 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
1095 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
1099 -- Establish the bound values for the choice depending upon whether the
1100 -- type of the case statement is static or not.
1102 if Is_OK_Static_Subtype
(Choice_Type
) then
1103 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
1104 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
1106 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
1107 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
1110 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
1111 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
1112 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
1114 -- Build the node for any missing choices that are smaller than any
1115 -- explicit choices given in the case.
1117 if Expr_Value
(Exp_Lo
) < Lo
then
1118 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
1121 -- Build the nodes representing any missing choices that lie between
1122 -- the explicit ones given in the case.
1124 for J
in 2 .. Case_Table
'Last loop
1125 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
1126 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
1128 if Lo
/= (Previous_Hi
+ 1) then
1129 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
1135 -- Build the node for any missing choices that are greater than any
1136 -- explicit choices given in the case.
1138 if Expr_Value
(Exp_Hi
) > Hi
then
1139 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
1142 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
1144 -- Warn on null others list if warning option set
1146 if Warn_On_Redundant_Constructs
1147 and then Comes_From_Source
(Others_Choice
)
1148 and then Is_Empty_List
(Choice_List
)
1150 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
1151 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
1153 end Expand_Others_Choice
;
1159 procedure No_OP
(C
: Node_Id
) is
1161 if Nkind
(C
) = N_Range
and then Warn_On_Redundant_Constructs
then
1162 Error_Msg_N
("choice is an empty range?r?", C
);
1166 -----------------------------
1167 -- Generic_Analyze_Choices --
1168 -----------------------------
1170 package body Generic_Analyze_Choices
is
1172 -- The following type is used to gather the entries for the choice
1173 -- table, so that we can then allocate the right length.
1176 type Link_Ptr
is access all Link
;
1179 Val
: Choice_Bounds
;
1183 ---------------------
1184 -- Analyze_Choices --
1185 ---------------------
1187 procedure Analyze_Choices
1188 (Alternatives
: List_Id
;
1191 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1192 -- The actual type against which the discrete choices are resolved.
1193 -- Note that this type is always the base type not the subtype of the
1194 -- ruling expression, index or discriminant.
1196 Expected_Type
: Entity_Id
;
1197 -- The expected type of each choice. Equal to Choice_Type, except if
1198 -- the expression is universal, in which case the choices can be of
1199 -- any integer type.
1202 -- A case statement alternative or a variant in a record type
1207 -- The node kind of the current Choice
1210 -- Set Expected type (= choice type except for universal integer,
1211 -- where we accept any integer type as a choice).
1213 if Choice_Type
= Universal_Integer
then
1214 Expected_Type
:= Any_Integer
;
1216 Expected_Type
:= Choice_Type
;
1219 -- Now loop through the case alternatives or record variants
1221 Alt
:= First
(Alternatives
);
1222 while Present
(Alt
) loop
1224 -- If pragma, just analyze it
1226 if Nkind
(Alt
) = N_Pragma
then
1229 -- Otherwise we have an alternative. In most cases the semantic
1230 -- processing leaves the list of choices unchanged
1232 -- Check each choice against its base type
1235 Choice
:= First
(Discrete_Choices
(Alt
));
1236 while Present
(Choice
) loop
1238 Kind
:= Nkind
(Choice
);
1240 -- Choice is a Range
1243 or else (Kind
= N_Attribute_Reference
1244 and then Attribute_Name
(Choice
) = Name_Range
)
1246 Resolve
(Choice
, Expected_Type
);
1248 -- Choice is a subtype name, nothing further to do now
1250 elsif Is_Entity_Name
(Choice
)
1251 and then Is_Type
(Entity
(Choice
))
1255 -- Choice is a subtype indication
1257 elsif Kind
= N_Subtype_Indication
then
1258 Resolve_Discrete_Subtype_Indication
1259 (Choice
, Expected_Type
);
1261 -- Others choice, no analysis needed
1263 elsif Kind
= N_Others_Choice
then
1266 -- Only other possibility is an expression
1269 Resolve
(Choice
, Expected_Type
);
1272 -- Move to next choice
1277 Process_Associated_Node
(Alt
);
1282 end Analyze_Choices
;
1284 end Generic_Analyze_Choices
;
1286 ---------------------------
1287 -- Generic_Check_Choices --
1288 ---------------------------
1290 package body Generic_Check_Choices
is
1292 -- The following type is used to gather the entries for the choice
1293 -- table, so that we can then allocate the right length.
1296 type Link_Ptr
is access all Link
;
1299 Val
: Choice_Bounds
;
1303 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
1309 procedure Check_Choices
1311 Alternatives
: List_Id
;
1313 Others_Present
: out Boolean)
1317 Raises_CE
: Boolean;
1318 -- Set True if one of the bounds of a choice raises CE
1321 -- This is where we post error messages for bounds out of range
1323 Choice_List
: Link_Ptr
:= null;
1324 -- Gather list of choices
1326 Num_Choices
: Nat
:= 0;
1327 -- Number of entries in Choice_List
1329 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1330 -- The actual type against which the discrete choices are resolved.
1331 -- Note that this type is always the base type not the subtype of the
1332 -- ruling expression, index or discriminant.
1334 Bounds_Type
: Entity_Id
;
1335 -- The type from which are derived the bounds of the values covered
1336 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1337 -- specifies a value outside of these bounds we have an error.
1341 -- The actual bounds of the above type
1343 Expected_Type
: Entity_Id
;
1344 -- The expected type of each choice. Equal to Choice_Type, except if
1345 -- the expression is universal, in which case the choices can be of
1346 -- any integer type.
1349 -- A case statement alternative or a variant in a record type
1354 -- The node kind of the current Choice
1356 Others_Choice
: Node_Id
:= Empty
;
1357 -- Remember others choice if it is present (empty otherwise)
1359 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
1360 -- Checks the validity of the bounds of a choice. When the bounds
1361 -- are static and no error occurred the bounds are collected for
1362 -- later entry into the choices table so that they can be sorted
1369 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
1374 -- First check if an error was already detected on either bounds
1376 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
1379 -- Do not insert non static choices in the table to be sorted
1381 elsif not Is_OK_Static_Expression
(Lo
)
1383 not Is_OK_Static_Expression
(Hi
)
1385 Process_Non_Static_Choice
(Choice
);
1388 -- Ignore range which raise constraint error
1390 elsif Raises_Constraint_Error
(Lo
)
1391 or else Raises_Constraint_Error
(Hi
)
1396 -- AI05-0188 : Within an instance the non-others choices do not
1397 -- have to belong to the actual subtype.
1399 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
1402 -- Otherwise we have an OK static choice
1405 Lo_Val
:= Expr_Value
(Lo
);
1406 Hi_Val
:= Expr_Value
(Hi
);
1408 -- Do not insert null ranges in the choices table
1410 if Lo_Val
> Hi_Val
then
1411 Process_Empty_Choice
(Choice
);
1416 -- Check for low bound out of range
1418 if Lo_Val
< Bounds_Lo
then
1420 -- If the choice is an entity name, then it is a type, and we
1421 -- want to post the message on the reference to this entity.
1422 -- Otherwise post it on the lower bound of the range.
1424 if Is_Entity_Name
(Choice
) then
1430 -- Specialize message for integer/enum type
1432 if Is_Integer_Type
(Bounds_Type
) then
1433 Error_Msg_Uint_1
:= Bounds_Lo
;
1434 Error_Msg_N
("minimum allowed choice value is^", Enode
);
1436 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
1437 Error_Msg_N
("minimum allowed choice value is%", Enode
);
1441 -- Check for high bound out of range
1443 if Hi_Val
> Bounds_Hi
then
1445 -- If the choice is an entity name, then it is a type, and we
1446 -- want to post the message on the reference to this entity.
1447 -- Otherwise post it on the upper bound of the range.
1449 if Is_Entity_Name
(Choice
) then
1455 -- Specialize message for integer/enum type
1457 if Is_Integer_Type
(Bounds_Type
) then
1458 Error_Msg_Uint_1
:= Bounds_Hi
;
1459 Error_Msg_N
("maximum allowed choice value is^", Enode
);
1461 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
1462 Error_Msg_N
("maximum allowed choice value is%", Enode
);
1466 -- Collect bounds in the list
1468 -- Note: we still store the bounds, even if they are out of range,
1469 -- since this may prevent unnecessary cascaded errors for values
1470 -- that are covered by such an excessive range.
1473 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1474 Num_Choices := Num_Choices + 1;
1477 -- Start of processing for Check_Choices
1481 Others_Present := False;
1483 -- If Subtyp is not a discrete type or there was some other error,
1484 -- then don't try any semantic checking on the choices since we have
1487 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
1491 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1492 -- bounds of its base type to determine the values covered by the
1493 -- discrete choices.
1495 -- In Ada 2012, if the subtype has a non-static predicate the full
1496 -- range of the base type must be covered as well.
1498 if Is_OK_Static_Subtype (Subtyp) then
1499 if not Has_Predicates (Subtyp)
1500 or else Has_Static_Predicate (Subtyp)
1502 Bounds_Type := Subtyp;
1504 Bounds_Type := Choice_Type;
1508 Bounds_Type := Choice_Type;
1511 -- Obtain static bounds of type, unless this is a generic formal
1512 -- discrete type for which all choices will be non-static.
1514 if not Is_Generic_Type (Root_Type (Bounds_Type))
1515 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1517 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1518 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1521 if Choice_Type = Universal_Integer then
1522 Expected_Type := Any_Integer;
1524 Expected_Type := Choice_Type;
1527 -- Now loop through the case alternatives or record variants
1529 Alt := First (Alternatives);
1530 while Present (Alt) loop
1532 -- If pragma, just analyze it
1534 if Nkind (Alt) = N_Pragma then
1537 -- Otherwise we have an alternative. In most cases the semantic
1538 -- processing leaves the list of choices unchanged
1540 -- Check each choice against its base type
1543 Choice := First (Discrete_Choices (Alt));
1544 while Present (Choice) loop
1545 Kind := Nkind (Choice);
1547 -- Choice is a Range
1550 or else (Kind = N_Attribute_Reference
1551 and then Attribute_Name (Choice) = Name_Range)
1553 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1555 -- Choice is a subtype name
1557 elsif Is_Entity_Name (Choice)
1558 and then Is_Type (Entity (Choice))
1560 -- Check for inappropriate type
1562 if not Covers (Expected_Type, Etype (Choice)) then
1563 Wrong_Type (Choice, Choice_Type);
1565 -- Type is OK, so check further
1568 E := Entity (Choice);
1570 -- Case of predicated subtype
1572 if Has_Predicates (E) then
1574 -- Use of non-static predicate is an error
1576 if not Is_Discrete_Type (E)
1577 or else not Has_Static_Predicate (E)
1578 or else Has_Dynamic_Predicate_Aspect (E)
1580 Bad_Predicated_Subtype_Use
1581 ("cannot use subtype& with non-static "
1582 & "predicate as case alternative",
1583 Choice, E, Suggest_Static => True);
1585 -- Static predicate case
1593 -- Loop through entries in predicate list,
1594 -- checking each entry. Note that if the
1595 -- list is empty, corresponding to a False
1596 -- predicate, then no choices are checked.
1598 P := First (Static_Discrete_Predicate (E));
1599 while Present (P) loop
1601 Set_Sloc (C, Sloc (Choice));
1602 Check (C, Low_Bound (C), High_Bound (C));
1607 Set_Has_SP_Choice (Alt);
1610 -- Not predicated subtype case
1612 elsif not Is_OK_Static_Subtype (E) then
1613 Process_Non_Static_Choice (Choice);
1616 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1620 -- Choice is a subtype indication
1622 elsif Kind = N_Subtype_Indication then
1623 Resolve_Discrete_Subtype_Indication
1624 (Choice, Expected_Type);
1626 if Etype (Choice) /= Any_Type then
1628 C : constant Node_Id := Constraint (Choice);
1629 R : constant Node_Id := Range_Expression (C);
1630 L : constant Node_Id := Low_Bound (R);
1631 H : constant Node_Id := High_Bound (R);
1634 E := Entity (Subtype_Mark (Choice));
1636 if not Is_OK_Static_Subtype (E) then
1637 Process_Non_Static_Choice (Choice);
1640 if Is_OK_Static_Expression (L)
1642 Is_OK_Static_Expression (H)
1644 if Expr_Value (L) > Expr_Value (H) then
1645 Process_Empty_Choice (Choice);
1647 if Is_Out_Of_Range (L, E) then
1648 Apply_Compile_Time_Constraint_Error
1649 (L, "static value out of range",
1650 CE_Range_Check_Failed);
1653 if Is_Out_Of_Range (H, E) then
1654 Apply_Compile_Time_Constraint_Error
1655 (H, "static value out of range",
1656 CE_Range_Check_Failed);
1661 Check (Choice, L, H);
1666 -- The others choice is only allowed for the last
1667 -- alternative and as its only choice.
1669 elsif Kind = N_Others_Choice then
1670 if not (Choice = First (Discrete_Choices (Alt))
1671 and then Choice = Last (Discrete_Choices (Alt))
1672 and then Alt = Last (Alternatives))
1675 ("the choice OTHERS must appear alone and last",
1680 Others_Present := True;
1681 Others_Choice := Choice;
1683 -- Only other possibility is an expression
1686 Check (Choice, Choice, Choice);
1689 -- Move to next choice
1694 Process_Associated_Node (Alt);
1700 -- Now we can create the Choice_Table, since we know how long
1701 -- it needs to be so we can allocate exactly the right length.
1704 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1707 -- Now copy the items we collected in the linked list into this
1708 -- newly allocated table (leave entry 0 unused for sorting).
1713 for J in 1 .. Num_Choices loop
1715 Choice_List := T.Nxt;
1716 Choice_Table (J) := T.Val;
1725 Others_Present or else (Choice_Type = Universal_Integer),
1728 -- If no others choice we are all done, otherwise we have one more
1729 -- step, which is to set the Others_Discrete_Choices field of the
1730 -- others choice (to contain all otherwise unspecified choices).
1731 -- Skip this if CE is known to be raised.
1733 if Others_Present and not Raises_CE then
1734 Expand_Others_Choice
1735 (Case_Table => Choice_Table,
1736 Others_Choice => Others_Choice,
1737 Choice_Type => Bounds_Type);
1742 end Generic_Check_Choices;