1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2013, 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, array
61 -- aggregate or record variant. The actual entries are stored in 1 .. Last,
62 -- but we have a 0 entry for convenience in sorting.
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 procedure Check_Choices
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 Analyze_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.
110 procedure Check_Choices
111 (Choice_Table
: in out Choice_Table_Type
;
112 Bounds_Type
: Entity_Id
;
114 Others_Present
: Boolean;
117 procedure Check_Against_Predicate
118 (Pred
: in out Node_Id
;
119 Choice
: Choice_Bounds
;
120 Prev_Lo
: in out Uint
;
121 Prev_Hi
: in out Uint
;
122 Error
: in out Boolean);
123 -- Determine whether a choice covers legal values as defined by a static
124 -- predicate set. Pred is a static predicate range. Choice is the choice
125 -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous
126 -- choice that covered a predicate set. Error denotes whether the check
127 -- found an illegal intersection.
129 procedure Explain_Non_Static_Bound
;
130 -- Called when we find a non-static bound, requiring the base type to
131 -- be covered. Provides where possible a helpful explanation of why the
132 -- bounds are non-static, since this is not always obvious.
134 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
135 -- Comparison routine for comparing Choice_Table entries. Use the lower
136 -- bound of each Choice as the key.
138 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
);
139 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
);
140 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
);
141 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
);
142 -- Issue an error message indicating that there are missing choices,
143 -- followed by the image of the missing choices themselves which lie
144 -- between Value1 and Value2 inclusive.
146 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
);
147 -- Emit an error message for each non-covered static predicate set.
148 -- Prev_Hi denotes the upper bound of the last choice that covered a
151 procedure Move_Choice
(From
: Natural; To
: Natural);
152 -- Move routine for sorting the Choice_Table
154 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
156 -----------------------------
157 -- Check_Against_Predicate --
158 -----------------------------
160 procedure Check_Against_Predicate
161 (Pred
: in out Node_Id
;
162 Choice
: Choice_Bounds
;
163 Prev_Lo
: in out Uint
;
164 Prev_Hi
: in out Uint
;
165 Error
: in out Boolean)
167 procedure Illegal_Range
171 -- Emit an error message regarding a choice that clashes with the
172 -- legal static predicate sets. Loc is the location of the choice
173 -- that introduced the illegal range. Lo .. Hi is the range.
175 function Inside_Range
178 Val
: Uint
) return Boolean;
179 -- Determine whether position Val within a discrete type is within
180 -- the range Lo .. Hi inclusive.
186 procedure Illegal_Range
192 Error_Msg_Name_1
:= Chars
(Bounds_Type
);
197 if Is_Integer_Type
(Bounds_Type
) then
198 Error_Msg_Uint_1
:= Lo
;
199 Error_Msg
("static predicate on % excludes value ^!", Loc
);
201 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
202 Error_Msg
("static predicate on % excludes value %!", Loc
);
208 if Is_Integer_Type
(Bounds_Type
) then
209 Error_Msg_Uint_1
:= Lo
;
210 Error_Msg_Uint_2
:= Hi
;
212 ("static predicate on % excludes range ^ .. ^!", Loc
);
214 Error_Msg_Name_2
:= Choice_Image
(Lo
, Bounds_Type
);
215 Error_Msg_Name_3
:= Choice_Image
(Hi
, Bounds_Type
);
217 ("static predicate on % excludes range % .. %!", Loc
);
226 function Inside_Range
229 Val
: Uint
) return Boolean
233 Val
= Lo
or else Val
= Hi
or else (Lo
< Val
and then Val
< Hi
);
238 Choice_Hi
: constant Uint
:= Expr_Value
(Choice
.Hi
);
239 Choice_Lo
: constant Uint
:= Expr_Value
(Choice
.Lo
);
246 -- Start of processing for Check_Against_Predicate
249 -- Find the proper error message location
251 if Present
(Choice
.Node
) then
252 Loc
:= Sloc
(Choice
.Node
);
254 Loc
:= Sloc
(Case_Node
);
257 if Present
(Pred
) then
258 Pred_Lo
:= Expr_Value
(Low_Bound
(Pred
));
259 Pred_Hi
:= Expr_Value
(High_Bound
(Pred
));
261 -- Previous choices managed to satisfy all static predicate sets
264 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
270 -- Step 1: Detect duplicate choices
272 if Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Lo
)
273 or else Inside_Range
(Choice_Lo
, Choice_Hi
, Prev_Hi
)
275 Error_Msg
("duplication of choice value", Loc
);
278 -- Step 2: Detect full coverage
280 -- Choice_Lo Choice_Hi
284 elsif Choice_Lo
= Pred_Lo
and then Choice_Hi
= Pred_Hi
then
285 Prev_Lo
:= Choice_Lo
;
286 Prev_Hi
:= Choice_Hi
;
289 -- Step 3: Detect all cases where a choice mentions values that are
290 -- not part of the static predicate sets.
292 -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi
293 -- +-----------+ . . . . . +=========+
296 elsif Choice_Lo
< Pred_Lo
and then Choice_Hi
< Pred_Lo
then
297 Illegal_Range
(Loc
, Choice_Lo
, Choice_Hi
);
300 -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi
301 -- +-----------+=========+===========+
304 elsif Choice_Lo
< Pred_Lo
305 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Hi
)
307 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
310 -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi
311 -- +=========+ . . . . +-----------+
314 elsif Pred_Lo
< Choice_Lo
and then Pred_Hi
< Choice_Lo
then
315 Missing_Choice
(Pred_Lo
, Pred_Hi
);
318 -- There may be several static predicate sets between the current
319 -- one and the choice. Inspect the next static predicate set.
322 Check_Against_Predicate
329 -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi
330 -- +=========+===========+-----------+
333 elsif Pred_Hi
< Choice_Hi
334 and then Inside_Range
(Pred_Lo
, Pred_Hi
, Choice_Lo
)
338 -- The choice may fall in a static predicate set. If this is the
339 -- case, avoid mentioning legal values in the error message.
341 if Present
(Pred
) then
342 Next_Lo
:= Expr_Value
(Low_Bound
(Pred
));
343 Next_Hi
:= Expr_Value
(High_Bound
(Pred
));
345 -- The next static predicate set is to the right of the choice
347 if Choice_Hi
< Next_Lo
and then Choice_Hi
< Next_Hi
then
348 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
350 Illegal_Range
(Loc
, Pred_Hi
+ 1, Next_Lo
- 1);
353 Illegal_Range
(Loc
, Pred_Hi
+ 1, Choice_Hi
);
358 -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi
359 -- +-----------+=========+-----------+
360 -- ^ illegal ^ ^ illegal ^
362 -- Emit an error on the low gap, disregard the upper gap
364 elsif Choice_Lo
< Pred_Lo
and then Pred_Hi
< Choice_Hi
then
365 Illegal_Range
(Loc
, Choice_Lo
, Pred_Lo
- 1);
368 -- Step 4: Detect all cases of partial or missing coverage
370 -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi
371 -- +=========+==========+===========+
375 -- An "others" choice covers all gaps
377 if Others_Present
then
378 Prev_Lo
:= Choice_Lo
;
379 Prev_Hi
:= Choice_Hi
;
382 -- Choice_Lo Choice_Hi Pred_Hi
383 -- +===========+===========+
386 -- The upper gap may be covered by a subsequent choice
388 elsif Pred_Lo
= Choice_Lo
then
389 Prev_Lo
:= Choice_Lo
;
390 Prev_Hi
:= Choice_Hi
;
392 -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi
393 -- +===========+=========+===========+===========+
394 -- ^ covered ^ ^ gap ^
396 else pragma Assert
(Pred_Lo
< Choice_Lo
);
398 -- A previous choice covered the gap up to the current choice
400 if Prev_Hi
= Choice_Lo
- 1 then
401 Prev_Lo
:= Choice_Lo
;
402 Prev_Hi
:= Choice_Hi
;
404 if Choice_Hi
= Pred_Hi
then
408 -- The previous choice did not intersect with the current
409 -- static predicate set.
411 elsif Prev_Hi
< Pred_Lo
then
412 Missing_Choice
(Pred_Lo
, Choice_Lo
- 1);
415 -- The previous choice covered part of the static predicate set
418 Missing_Choice
(Prev_Hi
, Choice_Lo
- 1);
423 end Check_Against_Predicate
;
425 ------------------------------
426 -- Explain_Non_Static_Bound --
427 ------------------------------
429 procedure Explain_Non_Static_Bound
is
433 if Nkind
(Case_Node
) = N_Variant_Part
then
434 Expr
:= Name
(Case_Node
);
436 Expr
:= Expression
(Case_Node
);
439 if Bounds_Type
/= Subtyp
then
441 -- If the case is a variant part, the expression is given by the
442 -- discriminant itself, and the bounds are the culprits.
444 if Nkind
(Case_Node
) = N_Variant_Part
then
446 ("bounds of & are not static," &
447 " alternatives must cover base type", Expr
, Expr
);
449 -- If this is a case statement, the expression may be non-static
450 -- or else the subtype may be at fault.
452 elsif Is_Entity_Name
(Expr
) then
454 ("bounds of & are not static," &
455 " alternatives must cover base type", Expr
, Expr
);
459 ("subtype of expression is not static,"
460 & " alternatives must cover base type!", Expr
);
463 -- Otherwise the expression is not static, even if the bounds of the
464 -- type are, or else there are missing alternatives. If both, the
465 -- additional information may be redundant but harmless.
467 elsif not Is_Entity_Name
(Expr
) then
469 ("subtype of expression is not static, "
470 & "alternatives must cover base type!", Expr
);
472 end Explain_Non_Static_Bound
;
478 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
481 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
483 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
490 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Node_Id
) is
492 Missing_Choice
(Expr_Value
(Value1
), Expr_Value
(Value2
));
495 procedure Missing_Choice
(Value1
: Node_Id
; Value2
: Uint
) is
497 Missing_Choice
(Expr_Value
(Value1
), Value2
);
500 procedure Missing_Choice
(Value1
: Uint
; Value2
: Node_Id
) is
502 Missing_Choice
(Value1
, Expr_Value
(Value2
));
505 procedure Missing_Choice
(Value1
: Uint
; Value2
: Uint
) is
506 Msg_Sloc
: constant Source_Ptr
:= Sloc
(Case_Node
);
509 -- AI05-0188 : within an instance the non-others choices do not have
510 -- to belong to the actual subtype.
512 if Ada_Version
>= Ada_2012
and then In_Instance
then
515 -- In some situations, we call this with a null range, and obviously
516 -- we don't want to complain in this case.
518 elsif Value1
> Value2
then
522 -- Case of only one value that is missing
524 if Value1
= Value2
then
525 if Is_Integer_Type
(Bounds_Type
) then
526 Error_Msg_Uint_1
:= Value1
;
527 Error_Msg
("missing case value: ^!", Msg_Sloc
);
529 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
530 Error_Msg
("missing case value: %!", Msg_Sloc
);
533 -- More than one choice value, so print range of values
536 if Is_Integer_Type
(Bounds_Type
) then
537 Error_Msg_Uint_1
:= Value1
;
538 Error_Msg_Uint_2
:= Value2
;
539 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
541 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
542 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
543 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
548 ---------------------
549 -- Missing_Choices --
550 ---------------------
552 procedure Missing_Choices
(Pred
: Node_Id
; Prev_Hi
: Uint
) is
559 while Present
(Set
) loop
560 Lo
:= Expr_Value
(Low_Bound
(Set
));
561 Hi
:= Expr_Value
(High_Bound
(Set
));
563 -- A choice covered part of a static predicate set
565 if Lo
<= Prev_Hi
and then Prev_Hi
< Hi
then
566 Missing_Choice
(Prev_Hi
+ 1, Hi
);
569 Missing_Choice
(Lo
, Hi
);
580 procedure Move_Choice
(From
: Natural; To
: Natural) is
582 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
587 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
588 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
589 Has_Predicate
: constant Boolean :=
590 Is_Static_Subtype
(Bounds_Type
)
591 and then Present
(Static_Predicate
(Bounds_Type
));
592 Num_Choices
: constant Nat
:= Choice_Table
'Last;
599 Prev_Choice
: Node_Id
;
603 -- Start of processing for Check_Choices
606 -- Choice_Table must start at 0 which is an unused location used by the
607 -- sorting algorithm. However the first valid position for a discrete
610 pragma Assert
(Choice_Table
'First = 0);
612 -- The choices do not cover the base range. Emit an error if "others" is
613 -- not available and return as there is no need for further processing.
615 if Num_Choices
= 0 then
616 if not Others_Present
then
617 Missing_Choice
(Bounds_Lo
, Bounds_Hi
);
623 Sorting
.Sort
(Positive (Choice_Table
'Last));
625 -- The type covered by the list of choices is actually a static subtype
626 -- subject to a static predicate. The predicate defines subsets of legal
627 -- values and requires finer grained analysis.
629 if Has_Predicate
then
630 Pred
:= First
(Static_Predicate
(Bounds_Type
));
631 Prev_Lo
:= Uint_Minus_1
;
632 Prev_Hi
:= Uint_Minus_1
;
635 for Index
in 1 .. Num_Choices
loop
636 Check_Against_Predicate
638 Choice
=> Choice_Table
(Index
),
643 -- The analysis detected an illegal intersection between a choice
644 -- and a static predicate set.
651 -- The choices may legally cover some of the static predicate sets,
652 -- but not all. Emit an error for each non-covered set.
654 if not Others_Present
then
655 Missing_Choices
(Pred
, Prev_Hi
);
661 Choice_Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
662 Choice_Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
663 Prev_Hi
:= Choice_Hi
;
665 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Choice_Lo
then
666 Missing_Choice
(Bounds_Lo
, Choice_Lo
- 1);
668 -- If values are missing outside of the subtype, add explanation.
669 -- No additional message if only one value is missing.
671 if Expr_Value
(Bounds_Lo
) < Choice_Lo
- 1 then
672 Explain_Non_Static_Bound
;
676 for Outer_Index
in 2 .. Num_Choices
loop
677 Choice_Lo
:= Expr_Value
(Choice_Table
(Outer_Index
).Lo
);
678 Choice_Hi
:= Expr_Value
(Choice_Table
(Outer_Index
).Hi
);
680 if Choice_Lo
<= Prev_Hi
then
681 Choice
:= Choice_Table
(Outer_Index
).Node
;
683 -- Find first previous choice that overlaps
685 for Inner_Index
in 1 .. Outer_Index
- 1 loop
687 Expr_Value
(Choice_Table
(Inner_Index
).Hi
)
689 Prev_Choice
:= Choice_Table
(Inner_Index
).Node
;
694 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
695 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
696 Error_Msg_N
("duplication of choice value#", Choice
);
698 Error_Msg_Sloc
:= Sloc
(Choice
);
699 Error_Msg_N
("duplication of choice value#", Prev_Choice
);
702 elsif not Others_Present
and then Choice_Lo
/= Prev_Hi
+ 1 then
703 Missing_Choice
(Prev_Hi
+ 1, Choice_Lo
- 1);
706 if Choice_Hi
> Prev_Hi
then
707 Prev_Hi
:= Choice_Hi
;
711 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Choice_Hi
then
712 Missing_Choice
(Choice_Hi
+ 1, Bounds_Hi
);
714 if Expr_Value
(Bounds_Hi
) > Choice_Hi
+ 1 then
715 Explain_Non_Static_Bound
;
725 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
726 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
731 -- For character, or wide [wide] character. If 7-bit ASCII graphic
732 -- range, then build and return appropriate character literal name
734 if Is_Standard_Character_Type
(Ctype
) then
735 C
:= UI_To_Int
(Value
);
737 if C
in 16#
20#
.. 16#
7E#
then
738 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
742 -- For user defined enumeration type, find enum/char literal
745 Lit
:= First_Literal
(Rtp
);
747 for J
in 1 .. UI_To_Int
(Value
) loop
751 -- If enumeration literal, just return its value
753 if Nkind
(Lit
) = N_Defining_Identifier
then
756 -- For character literal, get the name and use it if it is
757 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
760 Get_Decoded_Name_String
(Chars
(Lit
));
763 and then Name_Buffer
(2) in
764 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
771 -- If we fall through, we have a character literal which is not in
772 -- the 7-bit ASCII graphic set. For such cases, we construct the
773 -- name "type'val(nnn)" where type is the choice type, and nnn is
774 -- the pos value passed as an argument to Choice_Image.
776 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
778 Add_Str_To_Name_Buffer
("'val(");
780 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
781 Add_Char_To_Name_Buffer
(')');
785 --------------------------
786 -- Expand_Others_Choice --
787 --------------------------
789 procedure Expand_Others_Choice
790 (Case_Table
: Choice_Table_Type
;
791 Others_Choice
: Node_Id
;
792 Choice_Type
: Entity_Id
)
794 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
795 Choice_List
: constant List_Id
:= New_List
;
803 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
804 -- Builds a node representing the missing choices given by the
805 -- Value1 and Value2. A N_Range node is built if there is more than
806 -- one literal value missing. Otherwise a single N_Integer_Literal,
807 -- N_Identifier or N_Character_Literal is built depending on what
810 function Lit_Of
(Value
: Uint
) return Node_Id
;
811 -- Returns the Node_Id for the enumeration literal corresponding to the
812 -- position given by Value within the enumeration type Choice_Type.
818 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
823 -- If there is only one choice value missing between Value1 and
824 -- Value2, build an integer or enumeration literal to represent it.
826 if (Value2
- Value1
) = 0 then
827 if Is_Integer_Type
(Choice_Type
) then
828 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
829 Set_Etype
(Lit_Node
, Choice_Type
);
831 Lit_Node
:= Lit_Of
(Value1
);
834 -- Otherwise is more that one choice value that is missing between
835 -- Value1 and Value2, therefore build a N_Range node of either
836 -- integer or enumeration literals.
839 if Is_Integer_Type
(Choice_Type
) then
840 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
841 Set_Etype
(Lo
, Choice_Type
);
842 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
843 Set_Etype
(Hi
, Choice_Type
);
852 Low_Bound
=> Lit_Of
(Value1
),
853 High_Bound
=> Lit_Of
(Value2
));
864 function Lit_Of
(Value
: Uint
) return Node_Id
is
868 -- In the case where the literal is of type Character, there needs
869 -- to be some special handling since there is no explicit chain
870 -- of literals to search. Instead, a N_Character_Literal node
871 -- is created with the appropriate Char_Code and Chars fields.
873 if Is_Standard_Character_Type
(Choice_Type
) then
874 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
875 Lit
:= New_Node
(N_Character_Literal
, Loc
);
876 Set_Chars
(Lit
, Name_Find
);
877 Set_Char_Literal_Value
(Lit
, Value
);
878 Set_Etype
(Lit
, Choice_Type
);
879 Set_Is_Static_Expression
(Lit
, True);
882 -- Otherwise, iterate through the literals list of Choice_Type
883 -- "Value" number of times until the desired literal is reached
884 -- and then return an occurrence of it.
887 Lit
:= First_Literal
(Choice_Type
);
888 for J
in 1 .. UI_To_Int
(Value
) loop
892 return New_Occurrence_Of
(Lit
, Loc
);
896 -- Start of processing for Expand_Others_Choice
899 if Case_Table
'Last = 0 then
901 -- Special case: only an others case is present. The others case
902 -- covers the full range of the type.
904 if Is_Static_Subtype
(Choice_Type
) then
905 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
907 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
910 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
914 -- Establish the bound values for the choice depending upon whether the
915 -- type of the case statement is static or not.
917 if Is_OK_Static_Subtype
(Choice_Type
) then
918 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
919 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
921 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
922 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
925 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
926 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
927 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
929 -- Build the node for any missing choices that are smaller than any
930 -- explicit choices given in the case.
932 if Expr_Value
(Exp_Lo
) < Lo
then
933 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
936 -- Build the nodes representing any missing choices that lie between
937 -- the explicit ones given in the case.
939 for J
in 2 .. Case_Table
'Last loop
940 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
941 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
943 if Lo
/= (Previous_Hi
+ 1) then
944 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
950 -- Build the node for any missing choices that are greater than any
951 -- explicit choices given in the case.
953 if Expr_Value
(Exp_Hi
) > Hi
then
954 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
957 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
959 -- Warn on null others list if warning option set
961 if Warn_On_Redundant_Constructs
962 and then Comes_From_Source
(Others_Choice
)
963 and then Is_Empty_List
(Choice_List
)
965 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
966 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
968 end Expand_Others_Choice
;
974 procedure No_OP
(C
: Node_Id
) is
975 pragma Warnings
(Off
, C
);
980 --------------------------------
981 -- Generic_Choices_Processing --
982 --------------------------------
984 package body Generic_Choices_Processing
is
986 -- The following type is used to gather the entries for the choice
987 -- table, so that we can then allocate the right length.
990 type Link_Ptr
is access all Link
;
997 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
999 ---------------------
1000 -- Analyze_Choices --
1001 ---------------------
1003 procedure Analyze_Choices
1006 Raises_CE
: out Boolean;
1007 Others_Present
: out Boolean)
1012 -- This is where we post error messages for bounds out of range
1014 Choice_List
: Link_Ptr
:= null;
1015 -- Gather list of choices
1017 Num_Choices
: Nat
:= 0;
1018 -- Number of entries in Choice_List
1020 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
1021 -- The actual type against which the discrete choices are resolved.
1022 -- Note that this type is always the base type not the subtype of the
1023 -- ruling expression, index or discriminant.
1025 Bounds_Type
: Entity_Id
;
1026 -- The type from which are derived the bounds of the values covered
1027 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
1028 -- specifies a value outside of these bounds we have an error.
1032 -- The actual bounds of the above type
1034 Expected_Type
: Entity_Id
;
1035 -- The expected type of each choice. Equal to Choice_Type, except if
1036 -- the expression is universal, in which case the choices can be of
1037 -- any integer type.
1040 -- A case statement alternative or a variant in a record type
1045 -- The node kind of the current Choice
1047 Delete_Choice
: Boolean;
1048 -- Set to True to delete the current choice
1050 Others_Choice
: Node_Id
:= Empty
;
1051 -- Remember others choice if it is present (empty otherwise)
1053 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
1054 -- Checks the validity of the bounds of a choice. When the bounds
1055 -- are static and no error occurred the bounds are collected for
1056 -- later entry into the choices table so that they can be sorted
1063 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
1068 -- First check if an error was already detected on either bounds
1070 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
1073 -- Do not insert non static choices in the table to be sorted
1075 elsif not Is_Static_Expression
(Lo
)
1077 not Is_Static_Expression
(Hi
)
1079 Process_Non_Static_Choice
(Choice
);
1082 -- Ignore range which raise constraint error
1084 elsif Raises_Constraint_Error
(Lo
)
1085 or else Raises_Constraint_Error
(Hi
)
1090 -- AI05-0188 : Within an instance the non-others choices do not
1091 -- have to belong to the actual subtype.
1093 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
1096 -- Otherwise we have an OK static choice
1099 Lo_Val
:= Expr_Value
(Lo
);
1100 Hi_Val
:= Expr_Value
(Hi
);
1102 -- Do not insert null ranges in the choices table
1104 if Lo_Val
> Hi_Val
then
1105 Process_Empty_Choice
(Choice
);
1110 -- Check for low bound out of range
1112 if Lo_Val
< Bounds_Lo
then
1114 -- If the choice is an entity name, then it is a type, and we
1115 -- want to post the message on the reference to this entity.
1116 -- Otherwise post it on the lower bound of the range.
1118 if Is_Entity_Name
(Choice
) then
1124 -- Specialize message for integer/enum type
1126 if Is_Integer_Type
(Bounds_Type
) then
1127 Error_Msg_Uint_1
:= Bounds_Lo
;
1128 Error_Msg_N
("minimum allowed choice value is^", Enode
);
1130 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
1131 Error_Msg_N
("minimum allowed choice value is%", Enode
);
1135 -- Check for high bound out of range
1137 if Hi_Val
> Bounds_Hi
then
1139 -- If the choice is an entity name, then it is a type, and we
1140 -- want to post the message on the reference to this entity.
1141 -- Otherwise post it on the upper bound of the range.
1143 if Is_Entity_Name
(Choice
) then
1149 -- Specialize message for integer/enum type
1151 if Is_Integer_Type
(Bounds_Type
) then
1152 Error_Msg_Uint_1
:= Bounds_Hi
;
1153 Error_Msg_N
("maximum allowed choice value is^", Enode
);
1155 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
1156 Error_Msg_N
("maximum allowed choice value is%", Enode
);
1160 -- Collect bounds in the list
1162 -- Note: we still store the bounds, even if they are out of range,
1163 -- since this may prevent unnecessary cascaded errors for values
1164 -- that are covered by such an excessive range.
1167 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
1168 Num_Choices := Num_Choices + 1;
1171 -- Start of processing for Analyze_Choices
1175 Others_Present := False;
1177 -- If Subtyp is not a static subtype Ada 95 requires then we use the
1178 -- bounds of its base type to determine the values covered by the
1179 -- discrete choices.
1181 -- In Ada 2012, if the subtype has a non-static predicate the full
1182 -- range of the base type must be covered as well.
1184 if Is_OK_Static_Subtype (Subtyp) then
1185 if not Has_Predicates (Subtyp)
1186 or else Present (Static_Predicate (Subtyp))
1188 Bounds_Type := Subtyp;
1190 Bounds_Type := Choice_Type;
1194 Bounds_Type := Choice_Type;
1197 -- Obtain static bounds of type, unless this is a generic formal
1198 -- discrete type for which all choices will be non-static.
1200 if not Is_Generic_Type (Root_Type (Bounds_Type))
1201 or else Ekind (Bounds_Type) /= E_Enumeration_Type
1203 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
1204 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
1207 if Choice_Type = Universal_Integer then
1208 Expected_Type := Any_Integer;
1210 Expected_Type := Choice_Type;
1213 -- Now loop through the case alternatives or record variants
1215 Alt := First (Get_Alternatives (N));
1216 while Present (Alt) loop
1218 -- If pragma, just analyze it
1220 if Nkind (Alt) = N_Pragma then
1223 -- Otherwise check each choice against its base type
1226 Choice := First (Get_Choices (Alt));
1227 while Present (Choice) loop
1228 Delete_Choice := False;
1230 Kind := Nkind (Choice);
1232 -- Choice is a Range
1235 or else (Kind = N_Attribute_Reference
1236 and then Attribute_Name (Choice) = Name_Range)
1238 Resolve (Choice, Expected_Type);
1239 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
1241 -- Choice is a subtype name
1243 elsif Is_Entity_Name (Choice)
1244 and then Is_Type (Entity (Choice))
1246 if not Covers (Expected_Type, Etype (Choice)) then
1247 Wrong_Type (Choice, Choice_Type);
1250 E := Entity (Choice);
1252 -- Case of predicated subtype
1254 if Has_Predicates (E) then
1256 -- Use of non-static predicate is an error
1258 if not Is_Discrete_Type (E)
1259 or else No (Static_Predicate (E))
1261 Bad_Predicated_Subtype_Use
1262 ("cannot use subtype& with non-static "
1263 & "predicate as case alternative", Choice, E,
1264 Suggest_Static => True);
1266 -- Static predicate case
1270 Copy : constant List_Id := Empty_List;
1275 -- Loop through entries in predicate list,
1276 -- converting to choices. Note that if the
1277 -- list is empty, corresponding to a False
1278 -- predicate, then no choices are inserted.
1280 P := First (Static_Predicate (E));
1281 while Present (P) loop
1283 Set_Sloc (C, Sloc (Choice));
1284 Append_To (Copy, C);
1288 Insert_List_After (Choice, Copy);
1289 Delete_Choice := True;
1293 -- Not predicated subtype case
1295 elsif not Is_Static_Subtype (E) then
1296 Process_Non_Static_Choice (Choice);
1299 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
1303 -- Choice is a subtype indication
1305 elsif Kind = N_Subtype_Indication then
1306 Resolve_Discrete_Subtype_Indication
1307 (Choice, Expected_Type);
1309 -- Here for other than predicated subtype case
1311 if Etype (Choice) /= Any_Type then
1313 C : constant Node_Id := Constraint (Choice);
1314 R : constant Node_Id := Range_Expression (C);
1315 L : constant Node_Id := Low_Bound (R);
1316 H : constant Node_Id := High_Bound (R);
1319 E := Entity (Subtype_Mark (Choice));
1321 if not Is_Static_Subtype (E) then
1322 Process_Non_Static_Choice (Choice);
1325 if Is_OK_Static_Expression (L)
1326 and then Is_OK_Static_Expression (H)
1328 if Expr_Value (L) > Expr_Value (H) then
1329 Process_Empty_Choice (Choice);
1331 if Is_Out_Of_Range (L, E) then
1332 Apply_Compile_Time_Constraint_Error
1333 (L, "static value out of range",
1334 CE_Range_Check_Failed);
1337 if Is_Out_Of_Range (H, E) then
1338 Apply_Compile_Time_Constraint_Error
1339 (H, "static value out of range",
1340 CE_Range_Check_Failed);
1345 Check (Choice, L, H);
1350 -- The others choice is only allowed for the last
1351 -- alternative and as its only choice.
1353 elsif Kind = N_Others_Choice then
1354 if not (Choice = First (Get_Choices (Alt))
1355 and then Choice = Last (Get_Choices (Alt))
1356 and then Alt = Last (Get_Alternatives (N)))
1359 ("the choice OTHERS must appear alone and last",
1364 Others_Present := True;
1365 Others_Choice := Choice;
1367 -- Only other possibility is an expression
1370 Resolve (Choice, Expected_Type);
1371 Check (Choice, Choice, Choice);
1374 -- Move to next choice, deleting the current one if the
1375 -- flag requesting this deletion is set True.
1378 C : constant Node_Id := Choice;
1382 if Delete_Choice then
1388 Process_Associated_Node (Alt);
1394 -- Now we can create the Choice_Table, since we know how long
1395 -- it needs to be so we can allocate exactly the right length.
1398 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1401 -- Now copy the items we collected in the linked list into this
1402 -- newly allocated table (leave entry 0 unused for sorting).
1407 for J in 1 .. Num_Choices loop
1409 Choice_List := T.Nxt;
1410 Choice_Table (J) := T.Val;
1419 Others_Present or else (Choice_Type = Universal_Integer),
1422 -- If no others choice we are all done, otherwise we have one more
1423 -- step, which is to set the Others_Discrete_Choices field of the
1424 -- others choice (to contain all otherwise unspecified choices).
1425 -- Skip this if CE is known to be raised.
1427 if Others_Present and not Raises_CE then
1428 Expand_Others_Choice
1429 (Case_Table => Choice_Table,
1430 Others_Choice => Others_Choice,
1431 Choice_Type => Bounds_Type);
1434 end Analyze_Choices;
1436 end Generic_Choices_Processing;