1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2012, 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 Explain_Non_Static_Bound
;
118 -- Called when we find a non-static bound, requiring the base type to
119 -- be covered. Provides where possible a helpful explanation of why the
120 -- bounds are non-static, since this is not always obvious.
122 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
123 -- Comparison routine for comparing Choice_Table entries. Use the lower
124 -- bound of each Choice as the key.
126 procedure Move_Choice
(From
: Natural; To
: Natural);
127 -- Move routine for sorting the Choice_Table
129 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
131 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Node_Id
);
132 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Uint
);
133 procedure Issue_Msg
(Value1
: Uint
; Value2
: Node_Id
);
134 procedure Issue_Msg
(Value1
: Uint
; Value2
: Uint
);
135 -- Issue an error message indicating that there are missing choices,
136 -- followed by the image of the missing choices themselves which lie
137 -- between Value1 and Value2 inclusive.
143 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Node_Id
) is
145 Issue_Msg
(Expr_Value
(Value1
), Expr_Value
(Value2
));
148 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Uint
) is
150 Issue_Msg
(Expr_Value
(Value1
), Value2
);
153 procedure Issue_Msg
(Value1
: Uint
; Value2
: Node_Id
) is
155 Issue_Msg
(Value1
, Expr_Value
(Value2
));
158 procedure Issue_Msg
(Value1
: Uint
; Value2
: Uint
) is
159 Msg_Sloc
: constant Source_Ptr
:= Sloc
(Case_Node
);
162 -- AI05-0188 : within an instance the non-others choices do not
163 -- have to belong to the actual subtype.
165 if Ada_Version
>= Ada_2012
and then In_Instance
then
169 -- In some situations, we call this with a null range, and
170 -- obviously we don't want to complain in this case!
172 if Value1
> Value2
then
176 -- Case of only one value that is missing
178 if Value1
= Value2
then
179 if Is_Integer_Type
(Bounds_Type
) then
180 Error_Msg_Uint_1
:= Value1
;
181 Error_Msg
("missing case value: ^!", Msg_Sloc
);
183 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
184 Error_Msg
("missing case value: %!", Msg_Sloc
);
187 -- More than one choice value, so print range of values
190 if Is_Integer_Type
(Bounds_Type
) then
191 Error_Msg_Uint_1
:= Value1
;
192 Error_Msg_Uint_2
:= Value2
;
193 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
195 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
196 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
197 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
206 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
209 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
211 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
218 procedure Move_Choice
(From
: Natural; To
: Natural) is
220 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
223 ------------------------------
224 -- Explain_Non_Static_Bound --
225 ------------------------------
227 procedure Explain_Non_Static_Bound
is
231 if Nkind
(Case_Node
) = N_Variant_Part
then
232 Expr
:= Name
(Case_Node
);
234 Expr
:= Expression
(Case_Node
);
237 if Bounds_Type
/= Subtyp
then
239 -- If the case is a variant part, the expression is given by
240 -- the discriminant itself, and the bounds are the culprits.
242 if Nkind
(Case_Node
) = N_Variant_Part
then
244 ("bounds of & are not static," &
245 " alternatives must cover base type", Expr
, Expr
);
247 -- If this is a case statement, the expression may be
248 -- non-static or else the subtype may be at fault.
250 elsif Is_Entity_Name
(Expr
) then
252 ("bounds of & are not static," &
253 " alternatives must cover base type", Expr
, Expr
);
257 ("subtype of expression is not static,"
258 & " alternatives must cover base type!", Expr
);
261 -- Otherwise the expression is not static, even if the bounds of the
262 -- type are, or else there are missing alternatives. If both, the
263 -- additional information may be redundant but harmless.
265 elsif not Is_Entity_Name
(Expr
) then
267 ("subtype of expression is not static, "
268 & "alternatives must cover base type!", Expr
);
270 end Explain_Non_Static_Bound
;
272 -- Variables local to Check_Choices
275 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
276 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
278 Prev_Choice
: Node_Id
;
284 -- Start of processing for Check_Choices
287 -- Choice_Table must start at 0 which is an unused location used
288 -- by the sorting algorithm. However the first valid position for
289 -- a discrete choice is 1.
291 pragma Assert
(Choice_Table
'First = 0);
293 if Choice_Table
'Last = 0 then
294 if not Others_Present
then
295 Issue_Msg
(Bounds_Lo
, Bounds_Hi
);
301 Sorting
.Sort
(Positive (Choice_Table
'Last));
303 Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
304 Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
307 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Lo
then
308 Issue_Msg
(Bounds_Lo
, Lo
- 1);
310 -- If values are missing outside of the subtype, add explanation.
311 -- No additional message if only one value is missing.
313 if Expr_Value
(Bounds_Lo
) < Lo
- 1 then
314 Explain_Non_Static_Bound
;
318 for J
in 2 .. Choice_Table
'Last loop
319 Lo
:= Expr_Value
(Choice_Table
(J
).Lo
);
320 Hi
:= Expr_Value
(Choice_Table
(J
).Hi
);
322 if Lo
<= Prev_Hi
then
323 Choice
:= Choice_Table
(J
).Node
;
325 -- Find first previous choice that overlaps
327 for K
in 1 .. J
- 1 loop
328 if Lo
<= Expr_Value
(Choice_Table
(K
).Hi
) then
329 Prev_Choice
:= Choice_Table
(K
).Node
;
334 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
335 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
336 Error_Msg_N
("duplication of choice value#", Choice
);
338 Error_Msg_Sloc
:= Sloc
(Choice
);
339 Error_Msg_N
("duplication of choice value#", Prev_Choice
);
342 elsif not Others_Present
and then Lo
/= Prev_Hi
+ 1 then
343 Issue_Msg
(Prev_Hi
+ 1, Lo
- 1);
351 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Hi
then
352 Issue_Msg
(Hi
+ 1, Bounds_Hi
);
354 if Expr_Value
(Bounds_Hi
) > Hi
+ 1 then
355 Explain_Non_Static_Bound
;
364 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
365 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
370 -- For character, or wide [wide] character. If 7-bit ASCII graphic
371 -- range, then build and return appropriate character literal name
373 if Is_Standard_Character_Type
(Ctype
) then
374 C
:= UI_To_Int
(Value
);
376 if C
in 16#
20#
.. 16#
7E#
then
377 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
381 -- For user defined enumeration type, find enum/char literal
384 Lit
:= First_Literal
(Rtp
);
386 for J
in 1 .. UI_To_Int
(Value
) loop
390 -- If enumeration literal, just return its value
392 if Nkind
(Lit
) = N_Defining_Identifier
then
395 -- For character literal, get the name and use it if it is
396 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
399 Get_Decoded_Name_String
(Chars
(Lit
));
402 and then Name_Buffer
(2) in
403 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
410 -- If we fall through, we have a character literal which is not in
411 -- the 7-bit ASCII graphic set. For such cases, we construct the
412 -- name "type'val(nnn)" where type is the choice type, and nnn is
413 -- the pos value passed as an argument to Choice_Image.
415 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
417 Add_Str_To_Name_Buffer
("'val(");
419 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
420 Add_Char_To_Name_Buffer
(')');
424 --------------------------
425 -- Expand_Others_Choice --
426 --------------------------
428 procedure Expand_Others_Choice
429 (Case_Table
: Choice_Table_Type
;
430 Others_Choice
: Node_Id
;
431 Choice_Type
: Entity_Id
)
433 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
434 Choice_List
: constant List_Id
:= New_List
;
442 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
443 -- Builds a node representing the missing choices given by the
444 -- Value1 and Value2. A N_Range node is built if there is more than
445 -- one literal value missing. Otherwise a single N_Integer_Literal,
446 -- N_Identifier or N_Character_Literal is built depending on what
449 function Lit_Of
(Value
: Uint
) return Node_Id
;
450 -- Returns the Node_Id for the enumeration literal corresponding to the
451 -- position given by Value within the enumeration type Choice_Type.
457 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
462 -- If there is only one choice value missing between Value1 and
463 -- Value2, build an integer or enumeration literal to represent it.
465 if (Value2
- Value1
) = 0 then
466 if Is_Integer_Type
(Choice_Type
) then
467 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
468 Set_Etype
(Lit_Node
, Choice_Type
);
470 Lit_Node
:= Lit_Of
(Value1
);
473 -- Otherwise is more that one choice value that is missing between
474 -- Value1 and Value2, therefore build a N_Range node of either
475 -- integer or enumeration literals.
478 if Is_Integer_Type
(Choice_Type
) then
479 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
480 Set_Etype
(Lo
, Choice_Type
);
481 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
482 Set_Etype
(Hi
, Choice_Type
);
491 Low_Bound
=> Lit_Of
(Value1
),
492 High_Bound
=> Lit_Of
(Value2
));
503 function Lit_Of
(Value
: Uint
) return Node_Id
is
507 -- In the case where the literal is of type Character, there needs
508 -- to be some special handling since there is no explicit chain
509 -- of literals to search. Instead, a N_Character_Literal node
510 -- is created with the appropriate Char_Code and Chars fields.
512 if Is_Standard_Character_Type
(Choice_Type
) then
513 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
514 Lit
:= New_Node
(N_Character_Literal
, Loc
);
515 Set_Chars
(Lit
, Name_Find
);
516 Set_Char_Literal_Value
(Lit
, Value
);
517 Set_Etype
(Lit
, Choice_Type
);
518 Set_Is_Static_Expression
(Lit
, True);
521 -- Otherwise, iterate through the literals list of Choice_Type
522 -- "Value" number of times until the desired literal is reached
523 -- and then return an occurrence of it.
526 Lit
:= First_Literal
(Choice_Type
);
527 for J
in 1 .. UI_To_Int
(Value
) loop
531 return New_Occurrence_Of
(Lit
, Loc
);
535 -- Start of processing for Expand_Others_Choice
538 if Case_Table
'Last = 0 then
540 -- Special case: only an others case is present. The others case
541 -- covers the full range of the type.
543 if Is_Static_Subtype
(Choice_Type
) then
544 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
546 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
549 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
553 -- Establish the bound values for the choice depending upon whether the
554 -- type of the case statement is static or not.
556 if Is_OK_Static_Subtype
(Choice_Type
) then
557 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
558 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
560 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
561 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
564 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
565 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
566 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
568 -- Build the node for any missing choices that are smaller than any
569 -- explicit choices given in the case.
571 if Expr_Value
(Exp_Lo
) < Lo
then
572 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
575 -- Build the nodes representing any missing choices that lie between
576 -- the explicit ones given in the case.
578 for J
in 2 .. Case_Table
'Last loop
579 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
580 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
582 if Lo
/= (Previous_Hi
+ 1) then
583 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
589 -- Build the node for any missing choices that are greater than any
590 -- explicit choices given in the case.
592 if Expr_Value
(Exp_Hi
) > Hi
then
593 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
596 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
598 -- Warn on null others list if warning option set
600 if Warn_On_Redundant_Constructs
601 and then Comes_From_Source
(Others_Choice
)
602 and then Is_Empty_List
(Choice_List
)
604 Error_Msg_N
("?r?OTHERS choice is redundant", Others_Choice
);
605 Error_Msg_N
("\?r?previous choices cover all values", Others_Choice
);
607 end Expand_Others_Choice
;
613 procedure No_OP
(C
: Node_Id
) is
614 pragma Warnings
(Off
, C
);
619 --------------------------------
620 -- Generic_Choices_Processing --
621 --------------------------------
623 package body Generic_Choices_Processing
is
625 -- The following type is used to gather the entries for the choice
626 -- table, so that we can then allocate the right length.
629 type Link_Ptr
is access all Link
;
636 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
638 ---------------------
639 -- Analyze_Choices --
640 ---------------------
642 procedure Analyze_Choices
645 Raises_CE
: out Boolean;
646 Others_Present
: out Boolean)
651 -- This is where we post error messages for bounds out of range
653 Choice_List
: Link_Ptr
:= null;
654 -- Gather list of choices
656 Num_Choices
: Nat
:= 0;
657 -- Number of entries in Choice_List
659 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
660 -- The actual type against which the discrete choices are resolved.
661 -- Note that this type is always the base type not the subtype of the
662 -- ruling expression, index or discriminant.
664 Bounds_Type
: Entity_Id
;
665 -- The type from which are derived the bounds of the values covered
666 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
667 -- specifies a value outside of these bounds we have an error.
671 -- The actual bounds of the above type
673 Expected_Type
: Entity_Id
;
674 -- The expected type of each choice. Equal to Choice_Type, except if
675 -- the expression is universal, in which case the choices can be of
679 -- A case statement alternative or a variant in a record type
684 -- The node kind of the current Choice
686 Delete_Choice
: Boolean;
687 -- Set to True to delete the current choice
689 Others_Choice
: Node_Id
:= Empty
;
690 -- Remember others choice if it is present (empty otherwise)
692 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
693 -- Checks the validity of the bounds of a choice. When the bounds
694 -- are static and no error occurred the bounds are collected for
695 -- later entry into the choices table so that they can be sorted
702 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
707 -- First check if an error was already detected on either bounds
709 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
712 -- Do not insert non static choices in the table to be sorted
714 elsif not Is_Static_Expression
(Lo
)
716 not Is_Static_Expression
(Hi
)
718 Process_Non_Static_Choice
(Choice
);
721 -- Ignore range which raise constraint error
723 elsif Raises_Constraint_Error
(Lo
)
724 or else Raises_Constraint_Error
(Hi
)
729 -- AI05-0188 : Within an instance the non-others choices do not
730 -- have to belong to the actual subtype.
732 elsif Ada_Version
>= Ada_2012
and then In_Instance
then
735 -- Otherwise we have an OK static choice
738 Lo_Val
:= Expr_Value
(Lo
);
739 Hi_Val
:= Expr_Value
(Hi
);
741 -- Do not insert null ranges in the choices table
743 if Lo_Val
> Hi_Val
then
744 Process_Empty_Choice
(Choice
);
749 -- Check for low bound out of range
751 if Lo_Val
< Bounds_Lo
then
753 -- If the choice is an entity name, then it is a type, and we
754 -- want to post the message on the reference to this entity.
755 -- Otherwise post it on the lower bound of the range.
757 if Is_Entity_Name
(Choice
) then
763 -- Specialize message for integer/enum type
765 if Is_Integer_Type
(Bounds_Type
) then
766 Error_Msg_Uint_1
:= Bounds_Lo
;
767 Error_Msg_N
("minimum allowed choice value is^", Enode
);
769 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
770 Error_Msg_N
("minimum allowed choice value is%", Enode
);
774 -- Check for high bound out of range
776 if Hi_Val
> Bounds_Hi
then
778 -- If the choice is an entity name, then it is a type, and we
779 -- want to post the message on the reference to this entity.
780 -- Otherwise post it on the upper bound of the range.
782 if Is_Entity_Name
(Choice
) then
788 -- Specialize message for integer/enum type
790 if Is_Integer_Type
(Bounds_Type
) then
791 Error_Msg_Uint_1
:= Bounds_Hi
;
792 Error_Msg_N
("maximum allowed choice value is^", Enode
);
794 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
795 Error_Msg_N
("maximum allowed choice value is%", Enode
);
799 -- Collect bounds in the list
801 -- Note: we still store the bounds, even if they are out of range,
802 -- since this may prevent unnecessary cascaded errors for values
803 -- that are covered by such an excessive range.
806 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
807 Num_Choices := Num_Choices + 1;
810 -- Start of processing for Analyze_Choices
814 Others_Present := False;
816 -- If Subtyp is not a static subtype Ada 95 requires then we use the
817 -- bounds of its base type to determine the values covered by the
820 -- In Ada 2012, if the subtype has a non-static predicate the full
821 -- range of the base type must be covered as well.
823 if Is_OK_Static_Subtype (Subtyp) then
824 if not Has_Predicates (Subtyp)
825 or else Present (Static_Predicate (Subtyp))
827 Bounds_Type := Subtyp;
829 Bounds_Type := Choice_Type;
833 Bounds_Type := Choice_Type;
836 -- Obtain static bounds of type, unless this is a generic formal
837 -- discrete type for which all choices will be non-static.
839 if not Is_Generic_Type (Root_Type (Bounds_Type))
840 or else Ekind (Bounds_Type) /= E_Enumeration_Type
842 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
843 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
846 if Choice_Type = Universal_Integer then
847 Expected_Type := Any_Integer;
849 Expected_Type := Choice_Type;
852 -- Now loop through the case alternatives or record variants
854 Alt := First (Get_Alternatives (N));
855 while Present (Alt) loop
857 -- If pragma, just analyze it
859 if Nkind (Alt) = N_Pragma then
862 -- Otherwise check each choice against its base type
865 Choice := First (Get_Choices (Alt));
866 while Present (Choice) loop
867 Delete_Choice := False;
869 Kind := Nkind (Choice);
874 or else (Kind = N_Attribute_Reference
875 and then Attribute_Name (Choice) = Name_Range)
877 Resolve (Choice, Expected_Type);
878 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
880 -- Choice is a subtype name
882 elsif Is_Entity_Name (Choice)
883 and then Is_Type (Entity (Choice))
885 if not Covers (Expected_Type, Etype (Choice)) then
886 Wrong_Type (Choice, Choice_Type);
889 E := Entity (Choice);
891 -- Case of predicated subtype
893 if Has_Predicates (E) then
895 -- Use of non-static predicate is an error
897 if not Is_Discrete_Type (E)
898 or else No (Static_Predicate (E))
900 Bad_Predicated_Subtype_Use
901 ("cannot use subtype& with non-static "
902 & "predicate as case alternative", Choice, E);
904 -- Static predicate case
908 Copy : constant List_Id := Empty_List;
913 -- Loop through entries in predicate list,
914 -- converting to choices. Note that if the
915 -- list is empty, corresponding to a False
916 -- predicate, then no choices are inserted.
918 P := First (Static_Predicate (E));
919 while Present (P) loop
921 Set_Sloc (C, Sloc (Choice));
926 Insert_List_After (Choice, Copy);
927 Delete_Choice := True;
931 -- Not predicated subtype case
933 elsif not Is_Static_Subtype (E) then
934 Process_Non_Static_Choice (Choice);
937 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
941 -- Choice is a subtype indication
943 elsif Kind = N_Subtype_Indication then
944 Resolve_Discrete_Subtype_Indication
945 (Choice, Expected_Type);
947 -- Here for other than predicated subtype case
949 if Etype (Choice) /= Any_Type then
951 C : constant Node_Id := Constraint (Choice);
952 R : constant Node_Id := Range_Expression (C);
953 L : constant Node_Id := Low_Bound (R);
954 H : constant Node_Id := High_Bound (R);
957 E := Entity (Subtype_Mark (Choice));
959 if not Is_Static_Subtype (E) then
960 Process_Non_Static_Choice (Choice);
963 if Is_OK_Static_Expression (L)
964 and then Is_OK_Static_Expression (H)
966 if Expr_Value (L) > Expr_Value (H) then
967 Process_Empty_Choice (Choice);
969 if Is_Out_Of_Range (L, E) then
970 Apply_Compile_Time_Constraint_Error
971 (L, "static value out of range",
972 CE_Range_Check_Failed);
975 if Is_Out_Of_Range (H, E) then
976 Apply_Compile_Time_Constraint_Error
977 (H, "static value out of range",
978 CE_Range_Check_Failed);
983 Check (Choice, L, H);
988 -- The others choice is only allowed for the last
989 -- alternative and as its only choice.
991 elsif Kind = N_Others_Choice then
992 if not (Choice = First (Get_Choices (Alt))
993 and then Choice = Last (Get_Choices (Alt))
994 and then Alt = Last (Get_Alternatives (N)))
997 ("the choice OTHERS must appear alone and last",
1002 Others_Present := True;
1003 Others_Choice := Choice;
1005 -- Only other possibility is an expression
1008 Resolve (Choice, Expected_Type);
1009 Check (Choice, Choice, Choice);
1012 -- Move to next choice, deleting the current one if the
1013 -- flag requesting this deletion is set True.
1016 C : constant Node_Id := Choice;
1020 if Delete_Choice then
1026 Process_Associated_Node (Alt);
1032 -- Now we can create the Choice_Table, since we know how long
1033 -- it needs to be so we can allocate exactly the right length.
1036 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1039 -- Now copy the items we collected in the linked list into this
1040 -- newly allocated table (leave entry 0 unused for sorting).
1045 for J in 1 .. Num_Choices loop
1047 Choice_List := T.Nxt;
1048 Choice_Table (J) := T.Val;
1057 Others_Present or else (Choice_Type = Universal_Integer),
1060 -- If no others choice we are all done, otherwise we have one more
1061 -- step, which is to set the Others_Discrete_Choices field of the
1062 -- others choice (to contain all otherwise unspecified choices).
1063 -- Skip this if CE is known to be raised.
1065 if Others_Present and not Raises_CE then
1066 Expand_Others_Choice
1067 (Case_Table => Choice_Table,
1068 Others_Choice => Others_Choice,
1069 Choice_Type => Bounds_Type);
1072 end Analyze_Choices;
1074 end Generic_Choices_Processing;