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;
118 -- Flag to prevent cascaded errors when a static predicate is known to
119 -- be violated by one choice.
121 procedure Check_Against_Predicate
122 (Pred
: in out Node_Id
;
123 Choice
: Choice_Bounds
;
124 Prev_Lo
: in out Uint
;
125 Prev_Hi
: in out Uint
;
126 Error
: in out Boolean);
127 -- Determine whether a choice covers legal values as defined by a static
128 -- predicate set. Pred is a static predicate range. Choice is the choice
129 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
130 -- choice that covered a predicate set. Error denotes whether the check
131 -- found an illegal intersection.
133 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
);
134 -- Post message "duplication of choice value(s) bla bla at xx". Message
135 -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
137 procedure Explain_Non_Static_Bound
;
138 -- Called when we find a non-static bound, requiring the base type to
139 -- be covered. Provides where possible a helpful explanation of why the
140 -- bounds are non-static, since this is not always obvious.
142 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
143 -- Comparison routine for comparing Choice_Table entries. Use the lower
144 -- bound of each Choice as the key.
146 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
);
147 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
);
148 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
);
149 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
);
150 -- Issue an error message indicating that there are missing choices,
151 -- followed by the image of the missing choices themselves which lie
152 -- between Value1 and Value2 inclusive.
154 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
);
155 -- Emit an error message for each non-covered static predicate set.
156 -- Prev_Hi denotes the upper bound of the last choice covering a set.
158 procedure Move_Choice
(From
: Natural; To
: Natural);
159 -- Move routine for sorting the Choice_Table
161 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
163 -----------------------------
164 -- Check_Against_Predicate --
165 -----------------------------
167 procedure Check_Against_Predicate
168 (Pred
: in out Node_Id
;
169 Choice
: Choice_Bounds
;
170 Prev_Lo
: in out Uint
;
171 Prev_Hi
: in out Uint
;
172 Error
: in out Boolean)
174 procedure Illegal_Range
178 -- Emit an error message regarding a choice that clashes with the
179 -- legal static predicate sets. Loc is the location of the choice
180 -- that introduced the illegal range. Lo .. Hi is the range.
182 function Inside_Range
185 Val
: Uint
) return Boolean;
186 -- Determine whether position Val within a discrete type is within
187 -- the range Lo .. Hi inclusive.
193 procedure Illegal_Range
199 Error_Msg_Name_1
:= Chars
(Bounds_Type
);
204 if Is_Integer_Type
(Bounds_Type
) then
205 Error_Msg_Uint_1
:= Lo
;
206 Error_Msg
("static predicate on % excludes value ^!", Loc
);
208 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
209 Error_Msg
("static predicate on % excludes value %!", Loc
);
215 if Is_Integer_Type
(Bounds_Type
) then
216 Error_Msg_Uint_1
:= Lo
;
217 Error_Msg_Uint_2
:= Hi
;
219 ("static predicate on % excludes range ^ .. ^!", Loc
);
221 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
222 Error_Msg_Name_3
:= Choice_Image
(Hi
, Bounds_Type
);
224 ("static predicate on % excludes range % .. %!", Loc
);
233 function Inside_Range
236 Val
: Uint
) return Boolean
240 Val
= Lo
or else Val
= Hi
or else (Lo
< Val
and then Val
< Hi
);
245 Choice_Hi
: constant Uint
:= Expr_Value
(Choice
.Hi
);
246 Choice_Lo
: constant Uint
:= Expr_Value
(Choice
.Lo
);
254 -- Start of processing for Check_Against_Predicate
257 -- Find the proper error message location
259 if Present
(Choice
.Node
) then
267 if Present
(Pred
) then
268 Pred_Lo
:= Expr_Value
(Low_Bound
(Pred
));
269 Pred_Hi
:= Expr_Value
(High_Bound
(Pred
));
271 -- Previous choices managed to satisfy all static predicate sets
274 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
279 -- Step 1: Detect duplicate choices
281 if Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Lo
) then
282 Dup_Choice
(Prev_Lo
, UI_Min
(Prev_Hi
, Choice_Hi
), LocN
);
285 elsif Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Hi
) then
286 Dup_Choice
(UI_Max
(Choice_Lo
, Prev_Lo
), Prev_Hi
, LocN
);
289 -- Step 2: Detect full coverage
291 -- Choice_Lo Choice_Hi
295 elsif Choice_Lo
= Pred_Lo
and then Choice_Hi
= Pred_Hi
then
296 Prev_Lo
:= Choice_Lo
;
297 Prev_Hi
:= Choice_Hi
;
300 -- Step 3: Detect all cases where a choice mentions values that are
301 -- not part of the static predicate sets.
303 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
304 -- +-----------+ . . . . . +=========+
307 elsif Choice_Lo
< Pred_Lo
and then Choice_Hi
< Pred_Lo
then
308 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
311 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
312 -- +-----------+=========+===========+
315 elsif Choice_Lo
< Pred_Lo
316 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Hi
)
318 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
321 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
322 -- +=========+ . . . . +-----------+
325 elsif Pred_Lo
< Choice_Lo
and then Pred_Hi
< Choice_Lo
then
326 if Others_Present
then
328 -- Current predicate set is covered by others clause.
333 Missing_Choice
(Pred_Lo
, Pred_Hi
);
337 -- There may be several static predicate sets between the current
338 -- one and the choice. Inspect the next static predicate set.
341 Check_Against_Predicate
348 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
349 -- +=========+===========+-----------+
352 elsif Pred_Hi
< Choice_Hi
353 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Lo
)
357 -- The choice may fall in a static predicate set. If this is the
358 -- case, avoid mentioning legal values in the error message.
360 if Present
(Pred
) then
361 Next_Lo
:= Expr_Value
(Low_Bound
(Pred
));
362 Next_Hi
:= Expr_Value
(High_Bound
(Pred
));
364 -- The next static predicate set is to the right of the choice
366 if Choice_Hi
< Next_Lo
and then Choice_Hi
< Next_Hi
then
367 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
369 Illegal_Range
(Loc
, Pred_Hi
+ 1, Next_Lo
- 1);
372 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
377 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
378 -- +-----------+=========+-----------+
379 -- ^ illegal ^ ^ illegal ^
381 -- Emit an error on the low gap, disregard the upper gap
383 elsif Choice_Lo
< Pred_Lo
and then Pred_Hi
< Choice_Hi
then
384 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
387 -- Step 4: Detect all cases of partial or missing coverage
389 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
390 -- +=========+==========+===========+
394 -- An "others" choice covers all gaps
396 if Others_Present
then
397 Prev_Lo
:= Choice_Lo
;
398 Prev_Hi
:= Choice_Hi
;
400 -- Check whether predicate set is fully covered by choice
402 if Pred_Hi
= Choice_Hi
then
406 -- Choice_Lo Choice_Hi Pred_Hi
407 -- +===========+===========+
410 -- The upper gap may be covered by a subsequent choice
412 elsif Pred_Lo
= Choice_Lo
then
413 Prev_Lo
:= Choice_Lo
;
414 Prev_Hi
:= Choice_Hi
;
416 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
417 -- +===========+=========+===========+===========+
418 -- ^ covered ^ ^ gap ^
420 else pragma Assert
(Pred_Lo
< Choice_Lo
);
422 -- A previous choice covered the gap up to the current choice
424 if Prev_Hi
= Choice_Lo
- 1 then
425 Prev_Lo
:= Choice_Lo
;
426 Prev_Hi
:= Choice_Hi
;
428 if Choice_Hi
= Pred_Hi
then
432 -- The previous choice did not intersect with the current
433 -- static predicate set.
435 elsif Prev_Hi
< Pred_Lo
then
436 Missing_Choice
(Pred_Lo
, Choice_Lo
- 1);
439 -- The previous choice covered part of the static predicate set
440 -- but there is a gap after Prev_Hi.
443 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
448 end Check_Against_Predicate
;
454 procedure Dup_Choice
(Lo
, Hi
: Uint
; C
: Node_Id
) is
456 -- In some situations, we call this with a null range, and obviously
457 -- we don't want to complain in this case.
463 -- Case of only one value that is duplicated
469 if Is_Integer_Type
(Bounds_Type
) then
471 -- We have an integer value, Lo, but if the given choice
472 -- placement is a constant with that value, then use the
473 -- name of that constant instead in the message:
475 if Nkind
(C
) = N_Identifier
476 and then Compile_Time_Known_Value
(C
)
477 and then Expr_Value
(C
) = Lo
479 Error_Msg_N
("duplication of choice value: &#!", C
);
481 -- Not that special case, so just output the integer value
484 Error_Msg_Uint_1
:= Lo
;
485 Error_Msg_N
("duplication of choice value: ^#!", C
);
491 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
492 Error_Msg_N
("duplication of choice value: %#!", C
);
495 -- More than one choice value, so print range of values
500 if Is_Integer_Type
(Bounds_Type
) then
502 -- Similar to the above, if C is a range of known values which
503 -- match Lo and Hi, then use the names. We have to go to the
504 -- original nodes, since the values will have been rewritten
505 -- to their integer values.
507 if Nkind
(C
) = N_Range
508 and then Nkind
(Original_Node
(Low_Bound
(C
))) = N_Identifier
509 and then Nkind
(Original_Node
(High_Bound
(C
))) = N_Identifier
510 and then Compile_Time_Known_Value
(Low_Bound
(C
))
511 and then Compile_Time_Known_Value
(High_Bound
(C
))
512 and then Expr_Value
(Low_Bound
(C
)) = Lo
513 and then Expr_Value
(High_Bound
(C
)) = Hi
515 Error_Msg_Node_2
:= Original_Node
(High_Bound
(C
));
517 ("duplication of choice values: & .. &#!",
518 Original_Node
(Low_Bound
(C
)));
520 -- Not that special case, output integer values
523 Error_Msg_Uint_1
:= Lo
;
524 Error_Msg_Uint_2
:= Hi
;
525 Error_Msg_N
("duplication of choice values: ^ .. ^#!", C
);
531 Error_Msg_Name_1
:= Choice_Image
(Lo
, Bounds_Type
);
532 Error_Msg_Name_2
:= Choice_Image
(Hi
, Bounds_Type
);
533 Error_Msg_N
("duplication of choice values: % .. %#!", C
);
538 ------------------------------
539 -- Explain_Non_Static_Bound --
540 ------------------------------
542 procedure Explain_Non_Static_Bound
is
546 if Nkind
(Case_Node
) = N_Variant_Part
then
547 Expr
:= Name
(Case_Node
);
549 Expr
:= Expression
(Case_Node
);
552 if Bounds_Type
/= Subtyp
then
554 -- If the case is a variant part, the expression is given by the
555 -- discriminant itself, and the bounds are the culprits.
557 if Nkind
(Case_Node
) = N_Variant_Part
then
559 ("bounds of & are not static, "
560 & "alternatives must cover base type!", Expr
, Expr
);
562 -- If this is a case statement, the expression may be non-static
563 -- or else the subtype may be at fault.
565 elsif Is_Entity_Name
(Expr
) then
567 ("bounds of & are not static, "
568 & "alternatives must cover base type!", Expr
, Expr
);
572 ("subtype of expression is not static, "
573 & "alternatives must cover base type!", Expr
);
576 -- Otherwise the expression is not static, even if the bounds of the
577 -- type are, or else there are missing alternatives. If both, the
578 -- additional information may be redundant but harmless.
580 elsif not Is_Entity_Name
(Expr
) then
582 ("subtype of expression is not static, "
583 & "alternatives must cover base type!", Expr
);
585 end Explain_Non_Static_Bound
;
591 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
594 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
596 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
603 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
) is
605 Missing_Choice
(Expr_Value
(Value1
), Expr_Value
(Value2
));
608 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
) is
610 Missing_Choice
(Expr_Value
(Value1
), Value2
);
613 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
) is
615 Missing_Choice
(Value1
, Expr_Value
(Value2
));
622 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
) is
623 Msg_Sloc
: constant Source_Ptr
:= Sloc
(Case_Node
);
626 -- AI05-0188 : within an instance the non-others choices do not have
627 -- to belong to the actual subtype.
629 if Ada_Version
>= Ada_2012
and then In_Instance
then
632 -- In some situations, we call this with a null range, and obviously
633 -- we don't want to complain in this case.
635 elsif Value1
> Value2
then
638 -- If predicate is already known to be violated, do no check for
639 -- coverage error, to prevent cascaded messages.
641 elsif Predicate_Error
then
645 -- Case of only one value that is missing
647 if Value1
= Value2
then
648 if Is_Integer_Type
(Bounds_Type
) then
649 Error_Msg_Uint_1
:= Value1
;
650 Error_Msg
("missing case value: ^!", Msg_Sloc
);
652 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
653 Error_Msg
("missing case value: %!", Msg_Sloc
);
656 -- More than one choice value, so print range of values
659 if Is_Integer_Type
(Bounds_Type
) then
660 Error_Msg_Uint_1
:= Value1
;
661 Error_Msg_Uint_2
:= Value2
;
662 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
664 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
665 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
666 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
671 ---------------------
672 -- Missing_Choices --
673 ---------------------
675 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
) is
682 while Present
(Set
) loop
683 Lo
:= Expr_Value
(Low_Bound
(Set
));
684 Hi
:= Expr_Value
(High_Bound
(Set
));
686 -- A choice covered part of a static predicate set
688 if Lo
<= Prev_Hi
and then Prev_Hi
< Hi
then
689 Missing_Choice
(Prev_Hi
+ 1, Hi
);
692 Missing_Choice
(Lo
, Hi
);
703 procedure Move_Choice
(From
: Natural; To
: Natural) is
705 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
710 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
711 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
712 Num_Choices
: constant Nat
:= Choice_Table
'Last;
713 Has_Predicate
: constant Boolean :=
714 Is_OK_Static_Subtype
(Bounds_Type
)
715 and then Has_Static_Predicate
(Bounds_Type
);
722 Prev_Choice
: Node_Id
;
726 -- Start of processing for Check_Choice_Set
729 -- If the case is part of a predicate aspect specification, do not
730 -- recheck it against itself.
732 if Present
(Parent
(Case_Node
))
733 and then Nkind
(Parent
(Case_Node
)) = N_Aspect_Specification
738 Predicate_Error
:= False;
740 -- Choice_Table must start at 0 which is an unused location used by the
741 -- sorting algorithm. However the first valid position for a discrete
744 pragma Assert
(Choice_Table
'First = 0);
746 -- The choices do not cover the base range. Emit an error if "others" is
747 -- not available and return as there is no need for further processing.
749 if Num_Choices
= 0 then
750 if not Others_Present
then
751 Missing_Choice
(Bounds_Lo
, Bounds_Hi
);
757 Sorting
.Sort
(Positive (Choice_Table
'Last));
759 -- The type covered by the list of choices is actually a static subtype
760 -- subject to a static predicate. The predicate defines subsets of legal
761 -- values and requires finer grained analysis.
763 -- Note that in GNAT the predicate is considered static if the predicate
764 -- expression is static, independently of whether the aspect mentions
765 -- Static explicitly.
767 if Has_Predicate
then
768 Pred
:= First
(Static_Discrete_Predicate
(Bounds_Type
));
770 -- Make initial value smaller than 'First of type, so that first
771 -- range comparison succeeds. This applies both to integer types
772 -- and to enumeration types.
774 Prev_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
)) - 1;
779 for Index
in 1 .. Num_Choices
loop
780 Check_Against_Predicate
782 Choice
=> Choice_Table
(Index
),
787 -- The analysis detected an illegal intersection between a choice
788 -- and a static predicate set. Do not examine other choices unless
789 -- all errors are requested.
792 Predicate_Error
:= True;
794 if not All_Errors_Mode
then
800 if Predicate_Error
then
804 -- The choices may legally cover some of the static predicate sets,
805 -- but not all. Emit an error for each non-covered set.
807 if not Others_Present
then
808 Missing_Choices
(Pred
, Prev_Hi
);
814 Choice_Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
815 Choice_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
816 Prev_Hi
:= Choice_Hi
;
818 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Choice_Lo
then
819 Missing_Choice
(Bounds_Lo
, Choice_Lo
- 1);
821 -- If values are missing outside of the subtype, add explanation.
822 -- No additional message if only one value is missing.
824 if Expr_Value
(Bounds_Lo
) < Choice_Lo
- 1 then
825 Explain_Non_Static_Bound
;
829 for Outer_Index
in 2 .. Num_Choices
loop
830 Choice_Lo
:= Expr_Value
(Choice_Table
(Outer_Index
).Lo
);
831 Choice_Hi
:= Expr_Value
(Choice_Table
(Outer_Index
).Hi
);
833 if Choice_Lo
<= Prev_Hi
then
834 Choice
:= Choice_Table
(Outer_Index
).Node
;
836 -- Find first previous choice that overlaps
838 for Inner_Index
in 1 .. Outer_Index
- 1 loop
840 Expr_Value
(Choice_Table
(Inner_Index
).Hi
)
842 Prev_Choice
:= Choice_Table
(Inner_Index
).Node
;
847 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
848 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
850 (Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Choice
);
852 Error_Msg_Sloc
:= Sloc
(Choice
);
854 (Choice_Lo
, UI_Min
(Choice_Hi
, Prev_Hi
), Prev_Choice
);
857 elsif not Others_Present
and then Choice_Lo
/= Prev_Hi
+ 1 then
858 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
861 if Choice_Hi
> Prev_Hi
then
862 Prev_Hi
:= Choice_Hi
;
866 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Prev_Hi
then
867 Missing_Choice
(Prev_Hi
+ 1, Bounds_Hi
);
869 if Expr_Value
(Bounds_Hi
) > Prev_Hi
+ 1 then
870 Explain_Non_Static_Bound
;
874 end Check_Choice_Set
;
880 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
881 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
886 -- For character, or wide [wide] character. If 7-bit ASCII graphic
887 -- range, then build and return appropriate character literal name
889 if Is_Standard_Character_Type
(Ctype
) then
890 C
:= UI_To_Int
(Value
);
892 if C
in 16#
20#
.. 16#
7E#
then
893 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
897 -- For user defined enumeration type, find enum/char literal
900 Lit
:= First_Literal
(Rtp
);
902 for J
in 1 .. UI_To_Int
(Value
) loop
906 -- If enumeration literal, just return its value
908 if Nkind
(Lit
) = N_Defining_Identifier
then
911 -- For character literal, get the name and use it if it is
912 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
915 Get_Decoded_Name_String
(Chars
(Lit
));
918 and then Name_Buffer
(2) in
919 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
926 -- If we fall through, we have a character literal which is not in
927 -- the 7-bit ASCII graphic set. For such cases, we construct the
928 -- name "type'val(nnn)" where type is the choice type, and nnn is
929 -- the pos value passed as an argument to Choice_Image.
931 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
933 Add_Str_To_Name_Buffer
("'val(");
935 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
936 Add_Char_To_Name_Buffer
(')');
940 --------------------------
941 -- Expand_Others_Choice --
942 --------------------------
944 procedure Expand_Others_Choice
945 (Case_Table
: Choice_Table_Type
;
946 Others_Choice
: Node_Id
;
947 Choice_Type
: Entity_Id
)
949 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
950 Choice_List
: constant List_Id
:= New_List
;
958 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
959 -- Builds a node representing the missing choices given by Value1 and
960 -- Value2. A N_Range node is built if there is more than one literal
961 -- value missing. Otherwise a single N_Integer_Literal, N_Identifier
962 -- or N_Character_Literal is built depending on what Choice_Type is.
964 function Lit_Of
(Value
: Uint
) return Node_Id
;
965 -- Returns the Node_Id for the enumeration literal corresponding to the
966 -- position given by Value within the enumeration type Choice_Type.
972 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
977 -- If there is only one choice value missing between Value1 and
978 -- Value2, build an integer or enumeration literal to represent it.
980 if (Value2
- Value1
) = 0 then
981 if Is_Integer_Type
(Choice_Type
) then
982 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
983 Set_Etype
(Lit_Node
, Choice_Type
);
985 Lit_Node
:= Lit_Of
(Value1
);
988 -- Otherwise is more that one choice value that is missing between
989 -- Value1 and Value2, therefore build a N_Range node of either
990 -- integer or enumeration literals.
993 if Is_Integer_Type
(Choice_Type
) then
994 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
995 Set_Etype
(Lo
, Choice_Type
);
996 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
997 Set_Etype
(Hi
, Choice_Type
);
1006 Low_Bound
=> Lit_Of
(Value1
),
1007 High_Bound
=> Lit_Of
(Value2
));
1018 function Lit_Of
(Value
: Uint
) return Node_Id
is
1022 -- In the case where the literal is of type Character, there needs
1023 -- to be some special handling since there is no explicit chain
1024 -- of literals to search. Instead, a N_Character_Literal node
1025 -- is created with the appropriate Char_Code and Chars fields.
1027 if Is_Standard_Character_Type
(Choice_Type
) then
1028 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
1029 Lit
:= New_Node
(N_Character_Literal
, Loc
);
1030 Set_Chars
(Lit
, Name_Find
);
1031 Set_Char_Literal_Value
(Lit
, Value
);
1032 Set_Etype
(Lit
, Choice_Type
);
1033 Set_Is_Static_Expression
(Lit
, True);
1036 -- Otherwise, iterate through the literals list of Choice_Type
1037 -- "Value" number of times until the desired literal is reached
1038 -- and then return an occurrence of it.
1041 Lit
:= First_Literal
(Choice_Type
);
1042 for J
in 1 .. UI_To_Int
(Value
) loop
1046 return New_Occurrence_Of
(Lit
, Loc
);
1050 -- Start of processing for Expand_Others_Choice
1053 if Case_Table
'Last = 0 then
1055 -- Special case: only an others case is present. The others case
1056 -- covers the full range of the type.
1058 if Is_OK_Static_Subtype
(Choice_Type
) then
1059 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
1061 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
1064 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
1068 -- Establish the bound values for the choice depending upon whether the
1069 -- type of the case statement is static or not.
1071 if Is_OK_Static_Subtype
(Choice_Type
) then
1072 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
1073 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
1075 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
1076 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
1079 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
1080 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
1081 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
1083 -- Build the node for any missing choices that are smaller than any
1084 -- explicit choices given in the case.
1086 if Expr_Value
(Exp_Lo
) < Lo
then
1087 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
1090 -- Build the nodes representing any missing choices that lie between
1091 -- the explicit ones given in the case.
1093 for J
in 2 .. Case_Table
'Last loop
1094 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
1095 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
1097 if Lo
/= (Previous_Hi
+ 1) then
1098 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
1104 -- Build the node for any missing choices that are greater than any
1105 -- explicit choices given in the case.
1107 if Expr_Value
(Exp_Hi
) > Hi
then
1108 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
1111 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
1113 -- Warn on null others list if warning option set
1115 if Warn_On_Redundant_Constructs
1116 and then Comes_From_Source
(Others_Choice
)
1117 and then Is_Empty_List
(Choice_List
)
1119 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
1120 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
1122 end Expand_Others_Choice
;
1128 procedure No_OP
(C
: Node_Id
) is
1130 if Nkind
(C
) = N_Range
and then Warn_On_Redundant_Constructs
then
1131 Error_Msg_N
("choice is an empty range?r?", C
);
1135 -----------------------------
1136 -- Generic_Analyze_Choices --
1137 -----------------------------
1139 package body Generic_Analyze_Choices
is
1141 -- The following type is used to gather the entries for the choice
1142 -- table, so that we can then allocate the right length.
1145 type Link_Ptr
is access all Link
;
1148 Val
: Choice_Bounds
;
1152 ---------------------
1153 -- Analyze_Choices --
1154 ---------------------
1156 procedure Analyze_Choices
1157 (Alternatives
: List_Id
;
1160 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1161 -- The actual type against which the discrete choices are resolved.
1162 -- Note that this type is always the base type not the subtype of the
1163 -- ruling expression, index or discriminant.
1165 Expected_Type
: Entity_Id
;
1166 -- The expected type of each choice. Equal to Choice_Type, except if
1167 -- the expression is universal, in which case the choices can be of
1168 -- any integer type.
1171 -- A case statement alternative or a variant in a record type
1176 -- The node kind of the current Choice
1179 -- Set Expected type (= choice type except for universal integer,
1180 -- where we accept any integer type as a choice).
1182 if Choice_Type
= Universal_Integer
then
1183 Expected_Type
:= Any_Integer
;
1185 Expected_Type
:= Choice_Type
;
1188 -- Now loop through the case alternatives or record variants
1190 Alt
:= First
(Alternatives
);
1191 while Present
(Alt
) loop
1193 -- If pragma, just analyze it
1195 if Nkind
(Alt
) = N_Pragma
then
1198 -- Otherwise we have an alternative. In most cases the semantic
1199 -- processing leaves the list of choices unchanged
1201 -- Check each choice against its base type
1204 Choice
:= First
(Discrete_Choices
(Alt
));
1205 while Present
(Choice
) loop
1207 Kind
:= Nkind
(Choice
);
1209 -- Choice is a Range
1212 or else (Kind
= N_Attribute_Reference
1213 and then Attribute_Name
(Choice
) = Name_Range
)
1215 Resolve
(Choice
, Expected_Type
);
1217 -- Choice is a subtype name, nothing further to do now
1219 elsif Is_Entity_Name
(Choice
)
1220 and then Is_Type
(Entity
(Choice
))
1224 -- Choice is a subtype indication
1226 elsif Kind
= N_Subtype_Indication
then
1227 Resolve_Discrete_Subtype_Indication
1228 (Choice
, Expected_Type
);
1230 -- Others choice, no analysis needed
1232 elsif Kind
= N_Others_Choice
then
1235 -- Only other possibility is an expression
1238 Resolve
(Choice
, Expected_Type
);
1241 -- Move to next choice
1246 Process_Associated_Node
(Alt
);
1251 end Analyze_Choices
;
1253 end Generic_Analyze_Choices
;
1255 ---------------------------
1256 -- Generic_Check_Choices --
1257 ---------------------------
1259 package body Generic_Check_Choices
is
1261 -- The following type is used to gather the entries for the choice
1262 -- table, so that we can then allocate the right length.
1265 type Link_Ptr
is access all Link
;
1268 Val
: Choice_Bounds
;
1272 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
1278 procedure Check_Choices
1280 Alternatives
: List_Id
;
1282 Others_Present
: out Boolean)
1286 Raises_CE
: Boolean;
1287 -- Set True if one of the bounds of a choice raises CE
1290 -- This is where we post error messages for bounds out of range
1292 Choice_List
: Link_Ptr
:= null;
1293 -- Gather list of choices
1295 Num_Choices
: Nat
:= 0;
1296 -- Number of entries in Choice_List
1298 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1299 -- The actual type against which the discrete choices are resolved.
1300 -- Note that this type is always the base type not the subtype of the
1301 -- ruling expression, index or discriminant.
1303 Bounds_Type
: Entity_Id
;
1304 -- The type from which are derived the bounds of the values covered
1305 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1306 -- specifies a value outside of these bounds we have an error.
1310 -- The actual bounds of the above type
1312 Expected_Type
: Entity_Id
;
1313 -- The expected type of each choice. Equal to Choice_Type, except if
1314 -- the expression is universal, in which case the choices can be of
1315 -- any integer type.
1318 -- A case statement alternative or a variant in a record type
1323 -- The node kind of the current Choice
1325 Others_Choice
: Node_Id
:= Empty
;
1326 -- Remember others choice if it is present (empty otherwise)
1328 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
1329 -- Checks the validity of the bounds of a choice. When the bounds
1330 -- are static and no error occurred the bounds are collected for
1331 -- later entry into the choices table so that they can be sorted
1338 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
1343 -- First check if an error was already detected on either bounds
1345 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
1348 -- Do not insert non static choices in the table to be sorted
1350 elsif not Is_OK_Static_Expression
(Lo
)
1352 not Is_OK_Static_Expression
(Hi
)
1354 Process_Non_Static_Choice
(Choice
);
1357 -- Ignore range which raise constraint error
1359 elsif Raises_Constraint_Error
(Lo
)
1360 or else Raises_Constraint_Error
(Hi
)
1365 -- AI05-0188 : Within an instance the non-others choices do not
1366 -- have to belong to the actual subtype.
1368 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
1371 -- Otherwise we have an OK static choice
1374 Lo_Val
:= Expr_Value
(Lo
);
1375 Hi_Val
:= Expr_Value
(Hi
);
1377 -- Do not insert null ranges in the choices table
1379 if Lo_Val
> Hi_Val
then
1380 Process_Empty_Choice
(Choice
);
1385 -- Check for low bound out of range
1387 if Lo_Val
< Bounds_Lo
then
1389 -- If the choice is an entity name, then it is a type, and we
1390 -- want to post the message on the reference to this entity.
1391 -- Otherwise post it on the lower bound of the range.
1393 if Is_Entity_Name
(Choice
) then
1399 -- Specialize message for integer/enum type
1401 if Is_Integer_Type
(Bounds_Type
) then
1402 Error_Msg_Uint_1
:= Bounds_Lo
;
1403 Error_Msg_N
("minimum allowed choice value is^", Enode
);
1405 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
1406 Error_Msg_N
("minimum allowed choice value is%", Enode
);
1410 -- Check for high bound out of range
1412 if Hi_Val
> Bounds_Hi
then
1414 -- If the choice is an entity name, then it is a type, and we
1415 -- want to post the message on the reference to this entity.
1416 -- Otherwise post it on the upper bound of the range.
1418 if Is_Entity_Name
(Choice
) then
1424 -- Specialize message for integer/enum type
1426 if Is_Integer_Type
(Bounds_Type
) then
1427 Error_Msg_Uint_1
:= Bounds_Hi
;
1428 Error_Msg_N
("maximum allowed choice value is^", Enode
);
1430 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
1431 Error_Msg_N
("maximum allowed choice value is%", Enode
);
1435 -- Collect bounds in the list
1437 -- Note: we still store the bounds, even if they are out of range,
1438 -- since this may prevent unnecessary cascaded errors for values
1439 -- that are covered by such an excessive range.
1442 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1443 Num_Choices := Num_Choices + 1;
1446 -- Start of processing for Check_Choices
1450 Others_Present := False;
1452 -- If Subtyp is not a discrete type or there was some other error,
1453 -- then don't try any semantic checking on the choices since we have
1456 if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then
1460 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1461 -- bounds of its base type to determine the values covered by the
1462 -- discrete choices.
1464 -- In Ada 2012, if the subtype has a non-static predicate the full
1465 -- range of the base type must be covered as well.
1467 if Is_OK_Static_Subtype (Subtyp) then
1468 if not Has_Predicates (Subtyp)
1469 or else Has_Static_Predicate (Subtyp)
1471 Bounds_Type := Subtyp;
1473 Bounds_Type := Choice_Type;
1477 Bounds_Type := Choice_Type;
1480 -- Obtain static bounds of type, unless this is a generic formal
1481 -- discrete type for which all choices will be non-static.
1483 if not Is_Generic_Type (Root_Type (Bounds_Type))
1484 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1486 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1487 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1490 if Choice_Type = Universal_Integer then
1491 Expected_Type := Any_Integer;
1493 Expected_Type := Choice_Type;
1496 -- Now loop through the case alternatives or record variants
1498 Alt := First (Alternatives);
1499 while Present (Alt) loop
1501 -- If pragma, just analyze it
1503 if Nkind (Alt) = N_Pragma then
1506 -- Otherwise we have an alternative. In most cases the semantic
1507 -- processing leaves the list of choices unchanged
1509 -- Check each choice against its base type
1512 Choice := First (Discrete_Choices (Alt));
1513 while Present (Choice) loop
1514 Kind := Nkind (Choice);
1516 -- Choice is a Range
1519 or else (Kind = N_Attribute_Reference
1520 and then Attribute_Name (Choice) = Name_Range)
1522 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1524 -- Choice is a subtype name
1526 elsif Is_Entity_Name (Choice)
1527 and then Is_Type (Entity (Choice))
1529 -- Check for inappropriate type
1531 if not Covers (Expected_Type, Etype (Choice)) then
1532 Wrong_Type (Choice, Choice_Type);
1534 -- Type is OK, so check further
1537 E := Entity (Choice);
1539 -- Case of predicated subtype
1541 if Has_Predicates (E) then
1543 -- Use of non-static predicate is an error
1545 if not Is_Discrete_Type (E)
1546 or else not Has_Static_Predicate (E)
1547 or else Has_Dynamic_Predicate_Aspect (E)
1549 Bad_Predicated_Subtype_Use
1550 ("cannot use subtype& with non-static "
1551 & "predicate as case alternative",
1552 Choice, E, Suggest_Static => True);
1554 -- Static predicate case
1562 -- Loop through entries in predicate list,
1563 -- checking each entry. Note that if the
1564 -- list is empty, corresponding to a False
1565 -- predicate, then no choices are checked.
1567 P := First (Static_Discrete_Predicate (E));
1568 while Present (P) loop
1570 Set_Sloc (C, Sloc (Choice));
1571 Check (C, Low_Bound (C), High_Bound (C));
1576 Set_Has_SP_Choice (Alt);
1579 -- Not predicated subtype case
1581 elsif not Is_OK_Static_Subtype (E) then
1582 Process_Non_Static_Choice (Choice);
1585 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1589 -- Choice is a subtype indication
1591 elsif Kind = N_Subtype_Indication then
1592 Resolve_Discrete_Subtype_Indication
1593 (Choice, Expected_Type);
1595 if Etype (Choice) /= Any_Type then
1597 C : constant Node_Id := Constraint (Choice);
1598 R : constant Node_Id := Range_Expression (C);
1599 L : constant Node_Id := Low_Bound (R);
1600 H : constant Node_Id := High_Bound (R);
1603 E := Entity (Subtype_Mark (Choice));
1605 if not Is_OK_Static_Subtype (E) then
1606 Process_Non_Static_Choice (Choice);
1609 if Is_OK_Static_Expression (L)
1611 Is_OK_Static_Expression (H)
1613 if Expr_Value (L) > Expr_Value (H) then
1614 Process_Empty_Choice (Choice);
1616 if Is_Out_Of_Range (L, E) then
1617 Apply_Compile_Time_Constraint_Error
1618 (L, "static value out of range",
1619 CE_Range_Check_Failed);
1622 if Is_Out_Of_Range (H, E) then
1623 Apply_Compile_Time_Constraint_Error
1624 (H, "static value out of range",
1625 CE_Range_Check_Failed);
1630 Check (Choice, L, H);
1635 -- The others choice is only allowed for the last
1636 -- alternative and as its only choice.
1638 elsif Kind = N_Others_Choice then
1639 if not (Choice = First (Discrete_Choices (Alt))
1640 and then Choice = Last (Discrete_Choices (Alt))
1641 and then Alt = Last (Alternatives))
1644 ("the choice OTHERS must appear alone and last",
1649 Others_Present := True;
1650 Others_Choice := Choice;
1652 -- Only other possibility is an expression
1655 Check (Choice, Choice, Choice);
1658 -- Move to next choice
1663 Process_Associated_Node (Alt);
1669 -- Now we can create the Choice_Table, since we know how long
1670 -- it needs to be so we can allocate exactly the right length.
1673 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1676 -- Now copy the items we collected in the linked list into this
1677 -- newly allocated table (leave entry 0 unused for sorting).
1682 for J in 1 .. Num_Choices loop
1684 Choice_List := T.Nxt;
1685 Choice_Table (J) := T.Val;
1694 Others_Present or else (Choice_Type = Universal_Integer),
1697 -- If no others choice we are all done, otherwise we have one more
1698 -- step, which is to set the Others_Discrete_Choices field of the
1699 -- others choice (to contain all otherwise unspecified choices).
1700 -- Skip this if CE is known to be raised.
1702 if Others_Present and not Raises_CE then
1703 Expand_Others_Choice
1704 (Case_Table => Choice_Table,
1705 Others_Choice => Others_Choice,
1706 Choice_Type => Bounds_Type);
1711 end Generic_Check_Choices;