1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1996-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Namet
; use Namet
;
31 with Nlists
; use Nlists
;
32 with Nmake
; use Nmake
;
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 GNAT
.Heap_Sort_A
; use GNAT
.Heap_Sort_A
;
47 package body Sem_Case
is
49 -----------------------
50 -- Local Subprograms --
51 -----------------------
53 type Sort_Choice_Table_Type
is array (Nat
range <>) of Choice_Bounds
;
54 -- This new array type is used as the actual table type for sorting
55 -- discrete choices. The reason for not using Choice_Table_Type, is that
56 -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim
57 -- (this is not absolutely necessary but it makes the code more
60 procedure Check_Choices
61 (Choice_Table
: in out Sort_Choice_Table_Type
;
62 Bounds_Type
: Entity_Id
;
63 Others_Present
: Boolean;
64 Msg_Sloc
: Source_Ptr
);
65 -- This is the procedure which verifies that a set of case alternatives
66 -- or record variant choices has no duplicates, and covers the range
67 -- specified by Bounds_Type. Choice_Table contains the discrete choices
68 -- to check. These must start at position 1.
69 -- Furthermore Choice_Table (0) must exist. This element is used by
70 -- the sorting algorithm as a temporary. Others_Present is a flag
71 -- indicating whether or not an Others choice is present. Finally
72 -- Msg_Sloc gives the source location of the construct containing the
73 -- choices in the Choice_Table.
75 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
;
76 -- Given a Pos value of enumeration type Ctype, returns the name
77 -- ID of an appropriate string to be used in error message output.
79 procedure Expand_Others_Choice
80 (Case_Table
: Choice_Table_Type
;
81 Others_Choice
: Node_Id
;
82 Choice_Type
: Entity_Id
);
83 -- The case table is the table generated by a call to Analyze_Choices
84 -- (with just 1 .. Last_Choice entries present). Others_Choice is a
85 -- pointer to the N_Others_Choice node (this routine is only called if
86 -- an others choice is present), and Choice_Type is the discrete type
87 -- of the bounds. The effect of this call is to analyze the cases and
88 -- determine the set of values covered by others. This choice list is
89 -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
95 procedure Check_Choices
96 (Choice_Table
: in out Sort_Choice_Table_Type
;
97 Bounds_Type
: Entity_Id
;
98 Others_Present
: Boolean;
99 Msg_Sloc
: Source_Ptr
)
101 function Lt_Choice
(C1
, C2
: Natural) return Boolean;
102 -- Comparison routine for comparing Choice_Table entries. Use the lower
103 -- bound of each Choice as the key.
105 procedure Move_Choice
(From
: Natural; To
: Natural);
106 -- Move routine for sorting the Choice_Table
108 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Node_Id
);
109 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Uint
);
110 procedure Issue_Msg
(Value1
: Uint
; Value2
: Node_Id
);
111 procedure Issue_Msg
(Value1
: Uint
; Value2
: Uint
);
112 -- Issue an error message indicating that there are missing choices,
113 -- followed by the image of the missing choices themselves which lie
114 -- between Value1 and Value2 inclusive.
120 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Node_Id
) is
122 Issue_Msg
(Expr_Value
(Value1
), Expr_Value
(Value2
));
125 procedure Issue_Msg
(Value1
: Node_Id
; Value2
: Uint
) is
127 Issue_Msg
(Expr_Value
(Value1
), Value2
);
130 procedure Issue_Msg
(Value1
: Uint
; Value2
: Node_Id
) is
132 Issue_Msg
(Value1
, Expr_Value
(Value2
));
135 procedure Issue_Msg
(Value1
: Uint
; Value2
: Uint
) is
137 -- In some situations, we call this with a null range, and
138 -- obviously we don't want to complain in this case!
140 if Value1
> Value2
then
144 -- Case of only one value that is missing
146 if Value1
= Value2
then
147 if Is_Integer_Type
(Bounds_Type
) then
148 Error_Msg_Uint_1
:= Value1
;
149 Error_Msg
("missing case value: ^!", Msg_Sloc
);
151 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
152 Error_Msg
("missing case value: %!", Msg_Sloc
);
155 -- More than one choice value, so print range of values
158 if Is_Integer_Type
(Bounds_Type
) then
159 Error_Msg_Uint_1
:= Value1
;
160 Error_Msg_Uint_2
:= Value2
;
161 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
163 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
164 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
165 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
174 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
177 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
179 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
186 procedure Move_Choice
(From
: Natural; To
: Natural) is
188 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
191 -- Variables local to Check_Choices
194 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
195 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
197 Prev_Choice
: Node_Id
;
203 -- Start processing for Check_Choices
206 -- Choice_Table must start at 0 which is an unused location used
207 -- by the sorting algorithm. However the first valid position for
208 -- a discrete choice is 1.
210 pragma Assert
(Choice_Table
'First = 0);
212 if Choice_Table
'Last = 0 then
213 if not Others_Present
then
214 Issue_Msg
(Bounds_Lo
, Bounds_Hi
);
220 (Positive (Choice_Table
'Last),
221 Move_Choice
'Unrestricted_Access,
222 Lt_Choice
'Unrestricted_Access);
224 Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
225 Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
228 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Lo
then
229 Issue_Msg
(Bounds_Lo
, Lo
- 1);
232 for J
in 2 .. Choice_Table
'Last loop
233 Lo
:= Expr_Value
(Choice_Table
(J
).Lo
);
234 Hi
:= Expr_Value
(Choice_Table
(J
).Hi
);
236 if Lo
<= Prev_Hi
then
237 Prev_Choice
:= Choice_Table
(J
- 1).Node
;
238 Choice
:= Choice_Table
(J
).Node
;
240 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
241 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
242 Error_Msg_N
("duplication of choice value#", Choice
);
244 Error_Msg_Sloc
:= Sloc
(Choice
);
245 Error_Msg_N
("duplication of choice value#", Prev_Choice
);
248 elsif not Others_Present
and then Lo
/= Prev_Hi
+ 1 then
249 Issue_Msg
(Prev_Hi
+ 1, Lo
- 1);
255 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Hi
then
256 Issue_Msg
(Hi
+ 1, Bounds_Hi
);
264 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
265 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
270 -- For character, or wide [wide] character. If 7-bit ASCII graphic
271 -- range, then build and return appropriate character literal name
273 if Rtp
= Standard_Character
274 or else Rtp
= Standard_Wide_Character
275 or else Rtp
= Standard_Wide_Wide_Character
277 C
:= UI_To_Int
(Value
);
279 if C
in 16#
20#
.. 16#
7E#
then
280 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
284 -- For user defined enumeration type, find enum/char literal
287 Lit
:= First_Literal
(Rtp
);
289 for J
in 1 .. UI_To_Int
(Value
) loop
293 -- If enumeration literal, just return its value
295 if Nkind
(Lit
) = N_Defining_Identifier
then
298 -- For character literal, get the name and use it if it is
299 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
302 Get_Decoded_Name_String
(Chars
(Lit
));
305 and then Name_Buffer
(2) in
306 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
313 -- If we fall through, we have a character literal which is not in
314 -- the 7-bit ASCII graphic set. For such cases, we construct the
315 -- name "type'val(nnn)" where type is the choice type, and nnn is
316 -- the pos value passed as an argument to Choice_Image.
318 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
319 Name_Len
:= Name_Len
+ 1;
320 Name_Buffer
(Name_Len
) := ''';
321 Name_Len
:= Name_Len
+ 1;
322 Name_Buffer
(Name_Len
) := 'v';
323 Name_Len
:= Name_Len
+ 1;
324 Name_Buffer
(Name_Len
) := 'a';
325 Name_Len
:= Name_Len
+ 1;
326 Name_Buffer
(Name_Len
) := 'l';
327 Name_Len
:= Name_Len
+ 1;
328 Name_Buffer
(Name_Len
) := '(';
332 for J
in 1 .. UI_Image_Length
loop
333 Name_Len
:= Name_Len
+ 1;
334 Name_Buffer
(Name_Len
) := UI_Image_Buffer
(J
);
337 Name_Len
:= Name_Len
+ 1;
338 Name_Buffer
(Name_Len
) := ')';
342 --------------------------
343 -- Expand_Others_Choice --
344 --------------------------
346 procedure Expand_Others_Choice
347 (Case_Table
: Choice_Table_Type
;
348 Others_Choice
: Node_Id
;
349 Choice_Type
: Entity_Id
)
351 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
352 Choice_List
: constant List_Id
:= New_List
;
360 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
361 -- Builds a node representing the missing choices given by the
362 -- Value1 and Value2. A N_Range node is built if there is more than
363 -- one literal value missing. Otherwise a single N_Integer_Literal,
364 -- N_Identifier or N_Character_Literal is built depending on what
367 function Lit_Of
(Value
: Uint
) return Node_Id
;
368 -- Returns the Node_Id for the enumeration literal corresponding to the
369 -- position given by Value within the enumeration type Choice_Type.
375 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
380 -- If there is only one choice value missing between Value1 and
381 -- Value2, build an integer or enumeration literal to represent it.
383 if (Value2
- Value1
) = 0 then
384 if Is_Integer_Type
(Choice_Type
) then
385 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
386 Set_Etype
(Lit_Node
, Choice_Type
);
388 Lit_Node
:= Lit_Of
(Value1
);
391 -- Otherwise is more that one choice value that is missing between
392 -- Value1 and Value2, therefore build a N_Range node of either
393 -- integer or enumeration literals.
396 if Is_Integer_Type
(Choice_Type
) then
397 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
398 Set_Etype
(Lo
, Choice_Type
);
399 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
400 Set_Etype
(Hi
, Choice_Type
);
409 Low_Bound
=> Lit_Of
(Value1
),
410 High_Bound
=> Lit_Of
(Value2
));
421 function Lit_Of
(Value
: Uint
) return Node_Id
is
425 -- In the case where the literal is of type Character, there needs
426 -- to be some special handling since there is no explicit chain
427 -- of literals to search. Instead, a N_Character_Literal node
428 -- is created with the appropriate Char_Code and Chars fields.
430 if Root_Type
(Choice_Type
) = Standard_Character
432 Root_Type
(Choice_Type
) = Standard_Wide_Character
434 Root_Type
(Choice_Type
) = Standard_Wide_Wide_Character
436 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
437 Lit
:= New_Node
(N_Character_Literal
, Loc
);
438 Set_Chars
(Lit
, Name_Find
);
439 Set_Char_Literal_Value
(Lit
, Value
);
440 Set_Etype
(Lit
, Choice_Type
);
441 Set_Is_Static_Expression
(Lit
, True);
444 -- Otherwise, iterate through the literals list of Choice_Type
445 -- "Value" number of times until the desired literal is reached
446 -- and then return an occurrence of it.
449 Lit
:= First_Literal
(Choice_Type
);
450 for J
in 1 .. UI_To_Int
(Value
) loop
454 return New_Occurrence_Of
(Lit
, Loc
);
458 -- Start of processing for Expand_Others_Choice
461 if Case_Table
'Length = 0 then
463 -- Special case: only an others case is present.
464 -- The others case covers the full range of the type.
466 if Is_Static_Subtype
(Choice_Type
) then
467 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
469 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
472 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
476 -- Establish the bound values for the choice depending upon whether
477 -- the type of the case statement is static or not.
479 if Is_OK_Static_Subtype
(Choice_Type
) then
480 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
481 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
483 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
484 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
487 Lo
:= Expr_Value
(Case_Table
(Case_Table
'First).Lo
);
488 Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
489 Previous_Hi
:= Expr_Value
(Case_Table
(Case_Table
'First).Hi
);
491 -- Build the node for any missing choices that are smaller than any
492 -- explicit choices given in the case.
494 if Expr_Value
(Exp_Lo
) < Lo
then
495 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
498 -- Build the nodes representing any missing choices that lie between
499 -- the explicit ones given in the case.
501 for J
in Case_Table
'First + 1 .. Case_Table
'Last loop
502 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
503 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
505 if Lo
/= (Previous_Hi
+ 1) then
506 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
512 -- Build the node for any missing choices that are greater than any
513 -- explicit choices given in the case.
515 if Expr_Value
(Exp_Hi
) > Hi
then
516 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
519 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
521 -- Warn on null others list if warning option set
523 if Warn_On_Redundant_Constructs
524 and then Comes_From_Source
(Others_Choice
)
525 and then Is_Empty_List
(Choice_List
)
527 Error_Msg_N
("?OTHERS choice is redundant", Others_Choice
);
528 Error_Msg_N
("\previous choices cover all values", Others_Choice
);
530 end Expand_Others_Choice
;
536 procedure No_OP
(C
: Node_Id
) is
537 pragma Warnings
(Off
, C
);
543 --------------------------------
544 -- Generic_Choices_Processing --
545 --------------------------------
547 package body Generic_Choices_Processing
is
549 ---------------------
550 -- Analyze_Choices --
551 ---------------------
553 procedure Analyze_Choices
556 Choice_Table
: out Choice_Table_Type
;
557 Last_Choice
: out Nat
;
558 Raises_CE
: out Boolean;
559 Others_Present
: out Boolean)
561 pragma Assert
(Choice_Table
'First = 1);
566 -- This is where we post error messages for bounds out of range
568 Nb_Choices
: constant Nat
:= Choice_Table
'Length;
569 Sort_Choice_Table
: Sort_Choice_Table_Type
(0 .. Nb_Choices
);
571 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
572 -- The actual type against which the discrete choices are
573 -- resolved. Note that this type is always the base type not the
574 -- subtype of the ruling expression, index or discriminant.
576 Bounds_Type
: Entity_Id
;
577 -- The type from which are derived the bounds of the values
578 -- covered by the discrete choices (see 3.8.1 (4)). If a discrete
579 -- choice specifies a value outside of these bounds we have an error.
583 -- The actual bounds of the above type
585 Expected_Type
: Entity_Id
;
586 -- The expected type of each choice. Equal to Choice_Type, except
587 -- if the expression is universal, in which case the choices can
588 -- be of any integer type.
591 -- A case statement alternative or a variant in a record type
596 -- The node kind of the current Choice
598 Others_Choice
: Node_Id
:= Empty
;
599 -- Remember others choice if it is present (empty otherwise)
601 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
602 -- Checks the validity of the bounds of a choice. When the bounds
603 -- are static and no error occurred the bounds are entered into
604 -- the choices table so that they can be sorted later on.
610 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
615 -- First check if an error was already detected on either bounds
617 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
620 -- Do not insert non static choices in the table to be sorted
622 elsif not Is_Static_Expression
(Lo
)
623 or else not Is_Static_Expression
(Hi
)
625 Process_Non_Static_Choice
(Choice
);
628 -- Ignore range which raise constraint error
630 elsif Raises_Constraint_Error
(Lo
)
631 or else Raises_Constraint_Error
(Hi
)
636 -- Otherwise we have an OK static choice
639 Lo_Val
:= Expr_Value
(Lo
);
640 Hi_Val
:= Expr_Value
(Hi
);
642 -- Do not insert null ranges in the choices table
644 if Lo_Val
> Hi_Val
then
645 Process_Empty_Choice
(Choice
);
650 -- Check for low bound out of range
652 if Lo_Val
< Bounds_Lo
then
654 -- If the choice is an entity name, then it is a type, and
655 -- we want to post the message on the reference to this
656 -- entity. Otherwise we want to post it on the lower bound
659 if Is_Entity_Name
(Choice
) then
665 -- Specialize message for integer/enum type
667 if Is_Integer_Type
(Bounds_Type
) then
668 Error_Msg_Uint_1
:= Bounds_Lo
;
669 Error_Msg_N
("minimum allowed choice value is^", Enode
);
671 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
672 Error_Msg_N
("minimum allowed choice value is%", Enode
);
676 -- Check for high bound out of range
678 if Hi_Val
> Bounds_Hi
then
680 -- If the choice is an entity name, then it is a type, and
681 -- we want to post the message on the reference to this
682 -- entity. Otherwise we want to post it on the upper bound
685 if Is_Entity_Name
(Choice
) then
691 -- Specialize message for integer/enum type
693 if Is_Integer_Type
(Bounds_Type
) then
694 Error_Msg_Uint_1
:= Bounds_Hi
;
695 Error_Msg_N
("maximum allowed choice value is^", Enode
);
697 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
698 Error_Msg_N
("maximum allowed choice value is%", Enode
);
702 -- Store bounds in the table
704 -- Note: we still store the bounds, even if they are out of
705 -- range, since this may prevent unnecessary cascaded errors
706 -- for values that are covered by such an excessive range.
708 Last_Choice
:= Last_Choice
+ 1;
709 Sort_Choice_Table
(Last_Choice
).Lo
:= Lo
;
710 Sort_Choice_Table
(Last_Choice
).Hi
:= Hi
;
711 Sort_Choice_Table
(Last_Choice
).Node
:= Choice
;
714 -- Start of processing for Analyze_Choices
719 Others_Present
:= False;
721 -- If Subtyp is not a static subtype Ada 95 requires then we use
722 -- the bounds of its base type to determine the values covered by
723 -- the discrete choices.
725 if Is_OK_Static_Subtype
(Subtyp
) then
726 Bounds_Type
:= Subtyp
;
728 Bounds_Type
:= Choice_Type
;
731 -- Obtain static bounds of type, unless this is a generic formal
732 -- discrete type for which all choices will be non-static.
734 if not Is_Generic_Type
(Root_Type
(Bounds_Type
))
735 or else Ekind
(Bounds_Type
) /= E_Enumeration_Type
737 Bounds_Lo
:= Expr_Value
(Type_Low_Bound
(Bounds_Type
));
738 Bounds_Hi
:= Expr_Value
(Type_High_Bound
(Bounds_Type
));
741 if Choice_Type
= Universal_Integer
then
742 Expected_Type
:= Any_Integer
;
744 Expected_Type
:= Choice_Type
;
747 -- Now loop through the case alternatives or record variants
749 Alt
:= First
(Get_Alternatives
(N
));
750 while Present
(Alt
) loop
752 -- If pragma, just analyze it
754 if Nkind
(Alt
) = N_Pragma
then
757 -- Otherwise check each choice against its base type
760 Choice
:= First
(Get_Choices
(Alt
));
762 while Present
(Choice
) loop
764 Kind
:= Nkind
(Choice
);
769 or else (Kind
= N_Attribute_Reference
770 and then Attribute_Name
(Choice
) = Name_Range
)
772 Resolve
(Choice
, Expected_Type
);
773 Check
(Choice
, Low_Bound
(Choice
), High_Bound
(Choice
));
775 -- Choice is a subtype name
777 elsif Is_Entity_Name
(Choice
)
778 and then Is_Type
(Entity
(Choice
))
780 if not Covers
(Expected_Type
, Etype
(Choice
)) then
781 Wrong_Type
(Choice
, Choice_Type
);
784 E
:= Entity
(Choice
);
786 if not Is_Static_Subtype
(E
) then
787 Process_Non_Static_Choice
(Choice
);
790 (Choice
, Type_Low_Bound
(E
), Type_High_Bound
(E
));
794 -- Choice is a subtype indication
796 elsif Kind
= N_Subtype_Indication
then
797 Resolve_Discrete_Subtype_Indication
798 (Choice
, Expected_Type
);
800 if Etype
(Choice
) /= Any_Type
then
802 C
: constant Node_Id
:= Constraint
(Choice
);
803 R
: constant Node_Id
:= Range_Expression
(C
);
804 L
: constant Node_Id
:= Low_Bound
(R
);
805 H
: constant Node_Id
:= High_Bound
(R
);
808 E
:= Entity
(Subtype_Mark
(Choice
));
810 if not Is_Static_Subtype
(E
) then
811 Process_Non_Static_Choice
(Choice
);
814 if Is_OK_Static_Expression
(L
)
815 and then Is_OK_Static_Expression
(H
)
817 if Expr_Value
(L
) > Expr_Value
(H
) then
818 Process_Empty_Choice
(Choice
);
820 if Is_Out_Of_Range
(L
, E
) then
821 Apply_Compile_Time_Constraint_Error
822 (L
, "static value out of range",
823 CE_Range_Check_Failed
);
826 if Is_Out_Of_Range
(H
, E
) then
827 Apply_Compile_Time_Constraint_Error
828 (H
, "static value out of range",
829 CE_Range_Check_Failed
);
834 Check
(Choice
, L
, H
);
839 -- The others choice is only allowed for the last
840 -- alternative and as its only choice.
842 elsif Kind
= N_Others_Choice
then
843 if not (Choice
= First
(Get_Choices
(Alt
))
844 and then Choice
= Last
(Get_Choices
(Alt
))
845 and then Alt
= Last
(Get_Alternatives
(N
)))
848 ("the choice OTHERS must appear alone and last",
853 Others_Present
:= True;
854 Others_Choice
:= Choice
;
856 -- Only other possibility is an expression
859 Resolve
(Choice
, Expected_Type
);
860 Check
(Choice
, Choice
, Choice
);
866 Process_Associated_Node
(Alt
);
873 (Sort_Choice_Table
(0 .. Last_Choice
),
875 Others_Present
or else (Choice_Type
= Universal_Integer
),
878 -- Now copy the sorted discrete choices
880 for J
in 1 .. Last_Choice
loop
881 Choice_Table
(Choice_Table
'First - 1 + J
) := Sort_Choice_Table
(J
);
884 -- If no others choice we are all done, otherwise we have one more
885 -- step, which is to set the Others_Discrete_Choices field of the
886 -- others choice (to contain all otherwise unspecified choices).
887 -- Skip this if CE is known to be raised.
889 if Others_Present
and not Raises_CE
then
891 (Case_Table
=> Choice_Table
(1 .. Last_Choice
),
892 Others_Choice
=> Others_Choice
,
893 Choice_Type
=> Bounds_Type
);
897 -----------------------
898 -- Number_Of_Choices --
899 -----------------------
901 function Number_Of_Choices
(N
: Node_Id
) return Nat
is
903 -- A case statement alternative or a record variant
909 if No
(Get_Alternatives
(N
)) then
913 Alt
:= First_Non_Pragma
(Get_Alternatives
(N
));
914 while Present
(Alt
) loop
916 Choice
:= First
(Get_Choices
(Alt
));
917 while Present
(Choice
) loop
918 if Nkind
(Choice
) /= N_Others_Choice
then
925 Next_Non_Pragma
(Alt
);
929 end Number_Of_Choices
;
931 end Generic_Choices_Processing
;