1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2010, 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_Case
; use Sem_Case
;
36 with Sem_Eval
; use Sem_Eval
;
37 with Sem_Res
; use Sem_Res
;
38 with Sem_Util
; use Sem_Util
;
39 with Sem_Type
; use Sem_Type
;
40 with Snames
; use Snames
;
41 with Stand
; use Stand
;
42 with Sinfo
; use Sinfo
;
43 with Tbuild
; use Tbuild
;
44 with Uintp
; use Uintp
;
46 with GNAT
.Heap_Sort_G
;
48 package body Sem_Case
is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 type Sort_Choice_Table_Type
is array (Nat
range <>) of Choice_Bounds
;
55 -- This new array type is used as the actual table type for sorting
56 -- discrete choices. The reason for not using Choice_Table_Type, is that
57 -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algorithm
58 -- (this is not absolutely necessary but it makes the code more
61 procedure Check_Choices
62 (Choice_Table
: in out Sort_Choice_Table_Type
;
63 Bounds_Type
: Entity_Id
;
65 Others_Present
: Boolean;
67 -- This is the procedure which verifies that a set of case alternatives
68 -- or record variant choices has no duplicates, and covers the range
69 -- specified by Bounds_Type. Choice_Table contains the discrete choices
70 -- to check. These must start at position 1.
72 -- Furthermore Choice_Table (0) must exist. This element is used by
73 -- the sorting algorithm as a temporary. Others_Present is a flag
74 -- indicating whether or not an Others choice is present. Finally
75 -- Msg_Sloc gives the source location of the construct containing the
76 -- choices in the Choice_Table.
78 -- Bounds_Type is the type whose range must be covered by the alternatives
80 -- Subtyp is the subtype of the expression. If its bounds are non-static
81 -- the alternatives must cover its base type.
83 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
;
84 -- Given a Pos value of enumeration type Ctype, returns the name
85 -- ID of an appropriate string to be used in error message output.
87 procedure Expand_Others_Choice
88 (Case_Table
: Choice_Table_Type
;
89 Others_Choice
: Node_Id
;
90 Choice_Type
: Entity_Id
);
91 -- The case table is the table generated by a call to Analyze_Choices
92 -- (with just 1 .. Last_Choice entries present). Others_Choice is a
93 -- pointer to the N_Others_Choice node (this routine is only called if
94 -- an others choice is present), and Choice_Type is the discrete type
95 -- of the bounds. The effect of this call is to analyze the cases and
96 -- determine the set of values covered by others. This choice list is
97 -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
103 procedure Check_Choices
104 (Choice_Table
: in out Sort_Choice_Table_Type
;
105 Bounds_Type
: Entity_Id
;
107 Others_Present
: Boolean;
110 procedure Explain_Non_Static_Bound
;
111 -- Called when we find a non-static bound, requiring the base type to
112 -- be covered. Provides where possible a helpful explanation of why the
113 -- bounds are non-static, since this is not always obvious.
115 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
116 -- Comparison routine for comparing Choice_Table entries. Use the lower
117 -- bound of each Choice as the key.
119 procedure Move_Choice
(From
: Natural; To
: Natural);
120 -- Move routine for sorting the Choice_Table
122 package Sorting
is new GNAT
.Heap_Sort_G
(Move_Choice
, Lt_Choice
);
124 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Node_Id
);
125 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Uint
);
126 procedure Issue_Msg
(Value1
: Uint
; Value2
: Node_Id
);
127 procedure Issue_Msg
(Value1
: Uint
; Value2
: Uint
);
128 -- Issue an error message indicating that there are missing choices,
129 -- followed by the image of the missing choices themselves which lie
130 -- between Value1 and Value2 inclusive.
136 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Node_Id
) is
138 Issue_Msg
(Expr_Value
(Value1
), Expr_Value
(Value2
));
141 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Uint
) is
143 Issue_Msg
(Expr_Value
(Value1
), Value2
);
146 procedure Issue_Msg
(Value1
: Uint
; Value2
: Node_Id
) is
148 Issue_Msg
(Value1
, Expr_Value
(Value2
));
151 procedure Issue_Msg
(Value1
: Uint
; Value2
: Uint
) is
152 Msg_Sloc
: constant Source_Ptr
:= Sloc
(Case_Node
);
155 -- In some situations, we call this with a null range, and
156 -- obviously we don't want to complain in this case!
158 if Value1
> Value2
then
162 -- Case of only one value that is missing
164 if Value1
= Value2
then
165 if Is_Integer_Type
(Bounds_Type
) then
166 Error_Msg_Uint_1
:= Value1
;
167 Error_Msg
("missing case value: ^!", Msg_Sloc
);
169 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
170 Error_Msg
("missing case value: %!", Msg_Sloc
);
173 -- More than one choice value, so print range of values
176 if Is_Integer_Type
(Bounds_Type
) then
177 Error_Msg_Uint_1
:= Value1
;
178 Error_Msg_Uint_2
:= Value2
;
179 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
181 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
182 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
183 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
192 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
195 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
197 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
204 procedure Move_Choice
(From
: Natural; To
: Natural) is
206 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
209 ------------------------------
210 -- Explain_Non_Static_Bound --
211 ------------------------------
213 procedure Explain_Non_Static_Bound
is
217 if Nkind
(Case_Node
) = N_Variant_Part
then
218 Expr
:= Name
(Case_Node
);
220 Expr
:= Expression
(Case_Node
);
223 if Bounds_Type
/= Subtyp
then
225 -- If the case is a variant part, the expression is given by
226 -- the discriminant itself, and the bounds are the culprits.
228 if Nkind
(Case_Node
) = N_Variant_Part
then
230 ("bounds of & are not static," &
231 " alternatives must cover base type", Expr
, Expr
);
233 -- If this is a case statement, the expression may be
234 -- non-static or else the subtype may be at fault.
236 elsif Is_Entity_Name
(Expr
) then
238 ("bounds of & are not static," &
239 " alternatives must cover base type", Expr
, Expr
);
243 ("subtype of expression is not static,"
244 & " alternatives must cover base type!", Expr
);
247 -- Otherwise the expression is not static, even if the bounds of the
248 -- type are, or else there are missing alternatives. If both, the
249 -- additional information may be redundant but harmless.
251 elsif not Is_Entity_Name
(Expr
) then
253 ("subtype of expression is not static, "
254 & "alternatives must cover base type!", Expr
);
256 end Explain_Non_Static_Bound
;
258 -- Variables local to Check_Choices
261 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
262 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
264 Prev_Choice
: Node_Id
;
270 -- Start of processing for Check_Choices
273 -- Choice_Table must start at 0 which is an unused location used
274 -- by the sorting algorithm. However the first valid position for
275 -- a discrete choice is 1.
277 pragma Assert
(Choice_Table
'First = 0);
279 if Choice_Table
'Last = 0 then
280 if not Others_Present
then
281 Issue_Msg
(Bounds_Lo
, Bounds_Hi
);
287 Sorting
.Sort
(Positive (Choice_Table
'Last));
289 Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
290 Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
293 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Lo
then
294 Issue_Msg
(Bounds_Lo
, Lo
- 1);
296 -- If values are missing outside of the subtype, add explanation.
297 -- No additional message if only one value is missing.
299 if Expr_Value
(Bounds_Lo
) < Lo
- 1 then
300 Explain_Non_Static_Bound
;
304 for J
in 2 .. Choice_Table
'Last loop
305 Lo
:= Expr_Value
(Choice_Table
(J
).Lo
);
306 Hi
:= Expr_Value
(Choice_Table
(J
).Hi
);
308 if Lo
<= Prev_Hi
then
309 Prev_Choice
:= Choice_Table
(J
- 1).Node
;
310 Choice
:= Choice_Table
(J
).Node
;
312 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
313 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
314 Error_Msg_N
("duplication of choice value#", Choice
);
316 Error_Msg_Sloc
:= Sloc
(Choice
);
317 Error_Msg_N
("duplication of choice value#", Prev_Choice
);
320 elsif not Others_Present
and then Lo
/= Prev_Hi
+ 1 then
321 Issue_Msg
(Prev_Hi
+ 1, Lo
- 1);
327 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Hi
then
328 Issue_Msg
(Hi
+ 1, Bounds_Hi
);
330 if Expr_Value
(Bounds_Hi
) > Hi
+ 1 then
331 Explain_Non_Static_Bound
;
340 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
341 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
346 -- For character, or wide [wide] character. If 7-bit ASCII graphic
347 -- range, then build and return appropriate character literal name
349 if Is_Standard_Character_Type
(Ctype
) then
350 C
:= UI_To_Int
(Value
);
352 if C
in 16#
20#
.. 16#
7E#
then
353 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
357 -- For user defined enumeration type, find enum/char literal
360 Lit
:= First_Literal
(Rtp
);
362 for J
in 1 .. UI_To_Int
(Value
) loop
366 -- If enumeration literal, just return its value
368 if Nkind
(Lit
) = N_Defining_Identifier
then
371 -- For character literal, get the name and use it if it is
372 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
375 Get_Decoded_Name_String
(Chars
(Lit
));
378 and then Name_Buffer
(2) in
379 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
386 -- If we fall through, we have a character literal which is not in
387 -- the 7-bit ASCII graphic set. For such cases, we construct the
388 -- name "type'val(nnn)" where type is the choice type, and nnn is
389 -- the pos value passed as an argument to Choice_Image.
391 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
393 Add_Str_To_Name_Buffer
("'val(");
395 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
396 Add_Char_To_Name_Buffer
(')');
400 --------------------------
401 -- Expand_Others_Choice --
402 --------------------------
404 procedure Expand_Others_Choice
405 (Case_Table
: Choice_Table_Type
;
406 Others_Choice
: Node_Id
;
407 Choice_Type
: Entity_Id
)
409 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
410 Choice_List
: constant List_Id
:= New_List
;
418 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
419 -- Builds a node representing the missing choices given by the
420 -- Value1 and Value2. A N_Range node is built if there is more than
421 -- one literal value missing. Otherwise a single N_Integer_Literal,
422 -- N_Identifier or N_Character_Literal is built depending on what
425 function Lit_Of
(Value
: Uint
) return Node_Id
;
426 -- Returns the Node_Id for the enumeration literal corresponding to the
427 -- position given by Value within the enumeration type Choice_Type.
433 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
438 -- If there is only one choice value missing between Value1 and
439 -- Value2, build an integer or enumeration literal to represent it.
441 if (Value2
- Value1
) = 0 then
442 if Is_Integer_Type
(Choice_Type
) then
443 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
444 Set_Etype
(Lit_Node
, Choice_Type
);
446 Lit_Node
:= Lit_Of
(Value1
);
449 -- Otherwise is more that one choice value that is missing between
450 -- Value1 and Value2, therefore build a N_Range node of either
451 -- integer or enumeration literals.
454 if Is_Integer_Type
(Choice_Type
) then
455 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
456 Set_Etype
(Lo
, Choice_Type
);
457 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
458 Set_Etype
(Hi
, Choice_Type
);
467 Low_Bound
=> Lit_Of
(Value1
),
468 High_Bound
=> Lit_Of
(Value2
));
479 function Lit_Of
(Value
: Uint
) return Node_Id
is
483 -- In the case where the literal is of type Character, there needs
484 -- to be some special handling since there is no explicit chain
485 -- of literals to search. Instead, a N_Character_Literal node
486 -- is created with the appropriate Char_Code and Chars fields.
488 if Is_Standard_Character_Type
(Choice_Type
) then
489 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
490 Lit
:= New_Node
(N_Character_Literal
, Loc
);
491 Set_Chars
(Lit
, Name_Find
);
492 Set_Char_Literal_Value
(Lit
, Value
);
493 Set_Etype
(Lit
, Choice_Type
);
494 Set_Is_Static_Expression
(Lit
, True);
497 -- Otherwise, iterate through the literals list of Choice_Type
498 -- "Value" number of times until the desired literal is reached
499 -- and then return an occurrence of it.
502 Lit
:= First_Literal
(Choice_Type
);
503 for J
in 1 .. UI_To_Int
(Value
) loop
507 return New_Occurrence_Of
(Lit
, Loc
);
511 -- Start of processing for Expand_Others_Choice
514 if Case_Table
'Length = 0 then
516 -- Special case: only an others case is present.
517 -- The others case covers the full range of the type.
519 if Is_Static_Subtype
(Choice_Type
) then
520 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
522 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
525 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
529 -- Establish the bound values for the choice depending upon whether
530 -- the type of the case statement is static or not.
532 if Is_OK_Static_Subtype
(Choice_Type
) then
533 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
534 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
536 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
537 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
540 Lo
:= Expr_Value
(Case_Table
(Case_Table
'First).Lo
);
541 Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
542 Previous_Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
544 -- Build the node for any missing choices that are smaller than any
545 -- explicit choices given in the case.
547 if Expr_Value
(Exp_Lo
) < Lo
then
548 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
551 -- Build the nodes representing any missing choices that lie between
552 -- the explicit ones given in the case.
554 for J
in Case_Table
'First + 1 .. Case_Table
'Last loop
555 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
556 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
558 if Lo
/= (Previous_Hi
+ 1) then
559 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
565 -- Build the node for any missing choices that are greater than any
566 -- explicit choices given in the case.
568 if Expr_Value
(Exp_Hi
) > Hi
then
569 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
572 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
574 -- Warn on null others list if warning option set
576 if Warn_On_Redundant_Constructs
577 and then Comes_From_Source
(Others_Choice
)
578 and then Is_Empty_List
(Choice_List
)
580 Error_Msg_N
("?OTHERS choice is redundant", Others_Choice
);
581 Error_Msg_N
("\previous choices cover all values", Others_Choice
);
583 end Expand_Others_Choice
;
589 procedure No_OP
(C
: Node_Id
) is
590 pragma Warnings
(Off
, C
);
596 --------------------------------
597 -- Generic_Choices_Processing --
598 --------------------------------
600 package body Generic_Choices_Processing
is
602 ---------------------
603 -- Analyze_Choices --
604 ---------------------
606 procedure Analyze_Choices
609 Choice_Table
: out Choice_Table_Type
;
610 Last_Choice
: out Nat
;
611 Raises_CE
: out Boolean;
612 Others_Present
: out Boolean)
614 pragma Assert
(Choice_Table
'First = 1);
619 -- This is where we post error messages for bounds out of range
621 Nb_Choices
: constant Nat
:= Choice_Table
'Length;
622 Sort_Choice_Table
: Sort_Choice_Table_Type
(0 .. Nb_Choices
);
624 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
625 -- The actual type against which the discrete choices are resolved.
626 -- Note that this type is always the base type not the subtype of the
627 -- ruling expression, index or discriminant.
629 Bounds_Type
: Entity_Id
;
630 -- The type from which are derived the bounds of the values covered
631 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
632 -- specifies a value outside of these bounds we have an error.
636 -- The actual bounds of the above type
638 Expected_Type
: Entity_Id
;
639 -- The expected type of each choice. Equal to Choice_Type, except if
640 -- the expression is universal, in which case the choices can be of
644 -- A case statement alternative or a variant in a record type
649 -- The node kind of the current Choice
651 Others_Choice
: Node_Id
:= Empty
;
652 -- Remember others choice if it is present (empty otherwise)
654 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
655 -- Checks the validity of the bounds of a choice. When the bounds
656 -- are static and no error occurred the bounds are entered into the
657 -- choices table so that they can be sorted later on.
663 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
668 -- First check if an error was already detected on either bounds
670 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
673 -- Do not insert non static choices in the table to be sorted
675 elsif not Is_Static_Expression
(Lo
)
676 or else not Is_Static_Expression
(Hi
)
678 Process_Non_Static_Choice
(Choice
);
681 -- Ignore range which raise constraint error
683 elsif Raises_Constraint_Error
(Lo
)
684 or else Raises_Constraint_Error
(Hi
)
689 -- Otherwise we have an OK static choice
692 Lo_Val
:= Expr_Value
(Lo
);
693 Hi_Val
:= Expr_Value
(Hi
);
695 -- Do not insert null ranges in the choices table
697 if Lo_Val
> Hi_Val
then
698 Process_Empty_Choice
(Choice
);
703 -- Check for low bound out of range
705 if Lo_Val
< Bounds_Lo
then
707 -- If the choice is an entity name, then it is a type, and we
708 -- want to post the message on the reference to this entity.
709 -- Otherwise we want to post it on the lower bound of the
712 if Is_Entity_Name
(Choice
) then
718 -- Specialize message for integer/enum type
720 if Is_Integer_Type
(Bounds_Type
) then
721 Error_Msg_Uint_1
:= Bounds_Lo
;
722 Error_Msg_N
("minimum allowed choice value is^", Enode
);
724 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
725 Error_Msg_N
("minimum allowed choice value is%", Enode
);
729 -- Check for high bound out of range
731 if Hi_Val
> Bounds_Hi
then
733 -- If the choice is an entity name, then it is a type, and we
734 -- want to post the message on the reference to this entity.
735 -- Otherwise post it on the upper bound of the range.
737 if Is_Entity_Name
(Choice
) then
743 -- Specialize message for integer/enum type
745 if Is_Integer_Type
(Bounds_Type
) then
746 Error_Msg_Uint_1
:= Bounds_Hi
;
747 Error_Msg_N
("maximum allowed choice value is^", Enode
);
749 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
750 Error_Msg_N
("maximum allowed choice value is%", Enode
);
754 -- Store bounds in the table
756 -- Note: we still store the bounds, even if they are out of range,
757 -- since this may prevent unnecessary cascaded errors for values
758 -- that are covered by such an excessive range.
760 Last_Choice
:= Last_Choice
+ 1;
761 Sort_Choice_Table
(Last_Choice
).Lo
:= Lo
;
762 Sort_Choice_Table
(Last_Choice
).Hi
:= Hi
;
763 Sort_Choice_Table
(Last_Choice
).Node
:= Choice
;
766 -- Start of processing for Analyze_Choices
771 Others_Present
:= False;
773 -- If Subtyp is not a static subtype Ada 95 requires then we use the
774 -- bounds of its base type to determine the values covered by the
777 if Is_OK_Static_Subtype
(Subtyp
) then
778 Bounds_Type
:= Subtyp
;
780 Bounds_Type
:= Choice_Type
;
783 -- Obtain static bounds of type, unless this is a generic formal
784 -- discrete type for which all choices will be non-static.
786 if not Is_Generic_Type
(Root_Type
(Bounds_Type
))
787 or else Ekind
(Bounds_Type
) /= E_Enumeration_Type
789 Bounds_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
));
790 Bounds_Hi
:= Expr_Value
(Type_High_Bound
(Bounds_Type
));
793 if Choice_Type
= Universal_Integer
then
794 Expected_Type
:= Any_Integer
;
796 Expected_Type
:= Choice_Type
;
799 -- Now loop through the case alternatives or record variants
801 Alt
:= First
(Get_Alternatives
(N
));
802 while Present
(Alt
) loop
804 -- If pragma, just analyze it
806 if Nkind
(Alt
) = N_Pragma
then
809 -- Otherwise check each choice against its base type
812 Choice
:= First
(Get_Choices
(Alt
));
813 while Present
(Choice
) loop
815 Kind
:= Nkind
(Choice
);
820 or else (Kind
= N_Attribute_Reference
821 and then Attribute_Name
(Choice
) = Name_Range
)
823 Resolve
(Choice
, Expected_Type
);
824 Check
(Choice
, Low_Bound
(Choice
), High_Bound
(Choice
));
826 -- Choice is a subtype name
828 elsif Is_Entity_Name
(Choice
)
829 and then Is_Type
(Entity
(Choice
))
831 if not Covers
(Expected_Type
, Etype
(Choice
)) then
832 Wrong_Type
(Choice
, Choice_Type
);
835 E
:= Entity
(Choice
);
837 if not Is_Static_Subtype
(E
) then
838 Process_Non_Static_Choice
(Choice
);
841 (Choice
, Type_Low_Bound
(E
), Type_High_Bound
(E
));
845 -- Choice is a subtype indication
847 elsif Kind
= N_Subtype_Indication
then
848 Resolve_Discrete_Subtype_Indication
849 (Choice
, Expected_Type
);
851 if Etype
(Choice
) /= Any_Type
then
853 C
: constant Node_Id
:= Constraint
(Choice
);
854 R
: constant Node_Id
:= Range_Expression
(C
);
855 L
: constant Node_Id
:= Low_Bound
(R
);
856 H
: constant Node_Id
:= High_Bound
(R
);
859 E
:= Entity
(Subtype_Mark
(Choice
));
861 if not Is_Static_Subtype
(E
) then
862 Process_Non_Static_Choice
(Choice
);
865 if Is_OK_Static_Expression
(L
)
866 and then Is_OK_Static_Expression
(H
)
868 if Expr_Value
(L
) > Expr_Value
(H
) then
869 Process_Empty_Choice
(Choice
);
871 if Is_Out_Of_Range
(L
, E
) then
872 Apply_Compile_Time_Constraint_Error
873 (L
, "static value out of range",
874 CE_Range_Check_Failed
);
877 if Is_Out_Of_Range
(H
, E
) then
878 Apply_Compile_Time_Constraint_Error
879 (H
, "static value out of range",
880 CE_Range_Check_Failed
);
885 Check
(Choice
, L
, H
);
890 -- The others choice is only allowed for the last
891 -- alternative and as its only choice.
893 elsif Kind
= N_Others_Choice
then
894 if not (Choice
= First
(Get_Choices
(Alt
))
895 and then Choice
= Last
(Get_Choices
(Alt
))
896 and then Alt
= Last
(Get_Alternatives
(N
)))
899 ("the choice OTHERS must appear alone and last",
904 Others_Present
:= True;
905 Others_Choice
:= Choice
;
907 -- Only other possibility is an expression
910 Resolve
(Choice
, Expected_Type
);
911 Check
(Choice
, Choice
, Choice
);
917 Process_Associated_Node
(Alt
);
924 (Sort_Choice_Table
(0 .. Last_Choice
),
927 Others_Present
or else (Choice_Type
= Universal_Integer
),
930 -- Now copy the sorted discrete choices
932 for J
in 1 .. Last_Choice
loop
933 Choice_Table
(Choice_Table
'First - 1 + J
) := Sort_Choice_Table
(J
);
936 -- If no others choice we are all done, otherwise we have one more
937 -- step, which is to set the Others_Discrete_Choices field of the
938 -- others choice (to contain all otherwise unspecified choices).
939 -- Skip this if CE is known to be raised.
941 if Others_Present
and not Raises_CE
then
943 (Case_Table
=> Choice_Table
(1 .. Last_Choice
),
944 Others_Choice
=> Others_Choice
,
945 Choice_Type
=> Bounds_Type
);
949 -----------------------
950 -- Number_Of_Choices --
951 -----------------------
953 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
955 -- A case statement alternative or a record variant
961 if No
(Get_Alternatives
(N
)) then
965 Alt
:= First_Non_Pragma
(Get_Alternatives
(N
));
966 while Present
(Alt
) loop
968 Choice
:= First
(Get_Choices
(Alt
));
969 while Present
(Choice
) loop
970 if Nkind
(Choice
) /= N_Others_Choice
then
977 Next_Non_Pragma
(Alt
);
981 end Number_Of_Choices
;
983 end Generic_Choices_Processing
;