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_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 -- In some situations, we call this with a null range, and
163 -- obviously we don't want to complain in this case!
165 if Value1
> Value2
then
169 -- Case of only one value that is missing
171 if Value1
= Value2
then
172 if Is_Integer_Type
(Bounds_Type
) then
173 Error_Msg_Uint_1
:= Value1
;
174 Error_Msg
("missing case value: ^!", Msg_Sloc
);
176 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
177 Error_Msg
("missing case value: %!", Msg_Sloc
);
180 -- More than one choice value, so print range of values
183 if Is_Integer_Type
(Bounds_Type
) then
184 Error_Msg_Uint_1
:= Value1
;
185 Error_Msg_Uint_2
:= Value2
;
186 Error_Msg
("missing case values: ^ .. ^!", Msg_Sloc
);
188 Error_Msg_Name_1
:= Choice_Image
(Value1
, Bounds_Type
);
189 Error_Msg_Name_2
:= Choice_Image
(Value2
, Bounds_Type
);
190 Error_Msg
("missing case values: % .. %!", Msg_Sloc
);
199 function Lt_Choice
(C1
, C2
: Natural) return Boolean is
202 Expr_Value
(Choice_Table
(Nat
(C1
)).Lo
)
204 Expr_Value
(Choice_Table
(Nat
(C2
)).Lo
);
211 procedure Move_Choice
(From
: Natural; To
: Natural) is
213 Choice_Table
(Nat
(To
)) := Choice_Table
(Nat
(From
));
216 ------------------------------
217 -- Explain_Non_Static_Bound --
218 ------------------------------
220 procedure Explain_Non_Static_Bound
is
224 if Nkind
(Case_Node
) = N_Variant_Part
then
225 Expr
:= Name
(Case_Node
);
227 Expr
:= Expression
(Case_Node
);
230 if Bounds_Type
/= Subtyp
then
232 -- If the case is a variant part, the expression is given by
233 -- the discriminant itself, and the bounds are the culprits.
235 if Nkind
(Case_Node
) = N_Variant_Part
then
237 ("bounds of & are not static," &
238 " alternatives must cover base type", Expr
, Expr
);
240 -- If this is a case statement, the expression may be
241 -- non-static or else the subtype may be at fault.
243 elsif Is_Entity_Name
(Expr
) then
245 ("bounds of & are not static," &
246 " alternatives must cover base type", Expr
, Expr
);
250 ("subtype of expression is not static,"
251 & " alternatives must cover base type!", Expr
);
254 -- Otherwise the expression is not static, even if the bounds of the
255 -- type are, or else there are missing alternatives. If both, the
256 -- additional information may be redundant but harmless.
258 elsif not Is_Entity_Name
(Expr
) then
260 ("subtype of expression is not static, "
261 & "alternatives must cover base type!", Expr
);
263 end Explain_Non_Static_Bound
;
265 -- Variables local to Check_Choices
268 Bounds_Lo
: constant Node_Id
:= Type_Low_Bound
(Bounds_Type
);
269 Bounds_Hi
: constant Node_Id
:= Type_High_Bound
(Bounds_Type
);
271 Prev_Choice
: Node_Id
;
277 -- Start of processing for Check_Choices
280 -- Choice_Table must start at 0 which is an unused location used
281 -- by the sorting algorithm. However the first valid position for
282 -- a discrete choice is 1.
284 pragma Assert
(Choice_Table
'First = 0);
286 if Choice_Table
'Last = 0 then
287 if not Others_Present
then
288 Issue_Msg
(Bounds_Lo
, Bounds_Hi
);
294 Sorting
.Sort
(Positive (Choice_Table
'Last));
296 Lo
:= Expr_Value
(Choice_Table
(1).Lo
);
297 Hi
:= Expr_Value
(Choice_Table
(1).Hi
);
300 if not Others_Present
and then Expr_Value
(Bounds_Lo
) < Lo
then
301 Issue_Msg
(Bounds_Lo
, Lo
- 1);
303 -- If values are missing outside of the subtype, add explanation.
304 -- No additional message if only one value is missing.
306 if Expr_Value
(Bounds_Lo
) < Lo
- 1 then
307 Explain_Non_Static_Bound
;
311 for J
in 2 .. Choice_Table
'Last loop
312 Lo
:= Expr_Value
(Choice_Table
(J
).Lo
);
313 Hi
:= Expr_Value
(Choice_Table
(J
).Hi
);
315 if Lo
<= Prev_Hi
then
316 Choice
:= Choice_Table
(J
).Node
;
318 -- Find first previous choice that overlaps
320 for K
in 1 .. J
- 1 loop
321 if Lo
<= Expr_Value
(Choice_Table
(K
).Hi
) then
322 Prev_Choice
:= Choice_Table
(K
).Node
;
327 if Sloc
(Prev_Choice
) <= Sloc
(Choice
) then
328 Error_Msg_Sloc
:= Sloc
(Prev_Choice
);
329 Error_Msg_N
("duplication of choice value#", Choice
);
331 Error_Msg_Sloc
:= Sloc
(Choice
);
332 Error_Msg_N
("duplication of choice value#", Prev_Choice
);
335 elsif not Others_Present
and then Lo
/= Prev_Hi
+ 1 then
336 Issue_Msg
(Prev_Hi
+ 1, Lo
- 1);
344 if not Others_Present
and then Expr_Value
(Bounds_Hi
) > Hi
then
345 Issue_Msg
(Hi
+ 1, Bounds_Hi
);
347 if Expr_Value
(Bounds_Hi
) > Hi
+ 1 then
348 Explain_Non_Static_Bound
;
357 function Choice_Image
(Value
: Uint
; Ctype
: Entity_Id
) return Name_Id
is
358 Rtp
: constant Entity_Id
:= Root_Type
(Ctype
);
363 -- For character, or wide [wide] character. If 7-bit ASCII graphic
364 -- range, then build and return appropriate character literal name
366 if Is_Standard_Character_Type
(Ctype
) then
367 C
:= UI_To_Int
(Value
);
369 if C
in 16#
20#
.. 16#
7E#
then
370 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
374 -- For user defined enumeration type, find enum/char literal
377 Lit
:= First_Literal
(Rtp
);
379 for J
in 1 .. UI_To_Int
(Value
) loop
383 -- If enumeration literal, just return its value
385 if Nkind
(Lit
) = N_Defining_Identifier
then
388 -- For character literal, get the name and use it if it is
389 -- for a 7-bit ASCII graphic character in 16#20#..16#7E#.
392 Get_Decoded_Name_String
(Chars
(Lit
));
395 and then Name_Buffer
(2) in
396 Character'Val (16#
20#
) .. Character'Val (16#
7E#
)
403 -- If we fall through, we have a character literal which is not in
404 -- the 7-bit ASCII graphic set. For such cases, we construct the
405 -- name "type'val(nnn)" where type is the choice type, and nnn is
406 -- the pos value passed as an argument to Choice_Image.
408 Get_Name_String
(Chars
(First_Subtype
(Ctype
)));
410 Add_Str_To_Name_Buffer
("'val(");
412 Add_Str_To_Name_Buffer
(UI_Image_Buffer
(1 .. UI_Image_Length
));
413 Add_Char_To_Name_Buffer
(')');
417 --------------------------
418 -- Expand_Others_Choice --
419 --------------------------
421 procedure Expand_Others_Choice
422 (Case_Table
: Choice_Table_Type
;
423 Others_Choice
: Node_Id
;
424 Choice_Type
: Entity_Id
)
426 Loc
: constant Source_Ptr
:= Sloc
(Others_Choice
);
427 Choice_List
: constant List_Id
:= New_List
;
435 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
;
436 -- Builds a node representing the missing choices given by the
437 -- Value1 and Value2. A N_Range node is built if there is more than
438 -- one literal value missing. Otherwise a single N_Integer_Literal,
439 -- N_Identifier or N_Character_Literal is built depending on what
442 function Lit_Of
(Value
: Uint
) return Node_Id
;
443 -- Returns the Node_Id for the enumeration literal corresponding to the
444 -- position given by Value within the enumeration type Choice_Type.
450 function Build_Choice
(Value1
, Value2
: Uint
) return Node_Id
is
455 -- If there is only one choice value missing between Value1 and
456 -- Value2, build an integer or enumeration literal to represent it.
458 if (Value2
- Value1
) = 0 then
459 if Is_Integer_Type
(Choice_Type
) then
460 Lit_Node
:= Make_Integer_Literal
(Loc
, Value1
);
461 Set_Etype
(Lit_Node
, Choice_Type
);
463 Lit_Node
:= Lit_Of
(Value1
);
466 -- Otherwise is more that one choice value that is missing between
467 -- Value1 and Value2, therefore build a N_Range node of either
468 -- integer or enumeration literals.
471 if Is_Integer_Type
(Choice_Type
) then
472 Lo
:= Make_Integer_Literal
(Loc
, Value1
);
473 Set_Etype
(Lo
, Choice_Type
);
474 Hi
:= Make_Integer_Literal
(Loc
, Value2
);
475 Set_Etype
(Hi
, Choice_Type
);
484 Low_Bound
=> Lit_Of
(Value1
),
485 High_Bound
=> Lit_Of
(Value2
));
496 function Lit_Of
(Value
: Uint
) return Node_Id
is
500 -- In the case where the literal is of type Character, there needs
501 -- to be some special handling since there is no explicit chain
502 -- of literals to search. Instead, a N_Character_Literal node
503 -- is created with the appropriate Char_Code and Chars fields.
505 if Is_Standard_Character_Type
(Choice_Type
) then
506 Set_Character_Literal_Name
(Char_Code
(UI_To_Int
(Value
)));
507 Lit
:= New_Node
(N_Character_Literal
, Loc
);
508 Set_Chars
(Lit
, Name_Find
);
509 Set_Char_Literal_Value
(Lit
, Value
);
510 Set_Etype
(Lit
, Choice_Type
);
511 Set_Is_Static_Expression
(Lit
, True);
514 -- Otherwise, iterate through the literals list of Choice_Type
515 -- "Value" number of times until the desired literal is reached
516 -- and then return an occurrence of it.
519 Lit
:= First_Literal
(Choice_Type
);
520 for J
in 1 .. UI_To_Int
(Value
) loop
524 return New_Occurrence_Of
(Lit
, Loc
);
528 -- Start of processing for Expand_Others_Choice
531 if Case_Table
'Last = 0 then
533 -- Special case: only an others case is present.
534 -- The others case covers the full range of the type.
536 if Is_Static_Subtype
(Choice_Type
) then
537 Choice
:= New_Occurrence_Of
(Choice_Type
, Loc
);
539 Choice
:= New_Occurrence_Of
(Base_Type
(Choice_Type
), Loc
);
542 Set_Others_Discrete_Choices
(Others_Choice
, New_List
(Choice
));
546 -- Establish the bound values for the choice depending upon whether
547 -- the type of the case statement is static or not.
549 if Is_OK_Static_Subtype
(Choice_Type
) then
550 Exp_Lo
:= Type_Low_Bound
(Choice_Type
);
551 Exp_Hi
:= Type_High_Bound
(Choice_Type
);
553 Exp_Lo
:= Type_Low_Bound
(Base_Type
(Choice_Type
));
554 Exp_Hi
:= Type_High_Bound
(Base_Type
(Choice_Type
));
557 Lo
:= Expr_Value
(Case_Table
(1).Lo
);
558 Hi
:= Expr_Value
(Case_Table
(1).Hi
);
559 Previous_Hi
:= Expr_Value
(Case_Table
(1).Hi
);
561 -- Build the node for any missing choices that are smaller than any
562 -- explicit choices given in the case.
564 if Expr_Value
(Exp_Lo
) < Lo
then
565 Append
(Build_Choice
(Expr_Value
(Exp_Lo
), Lo
- 1), Choice_List
);
568 -- Build the nodes representing any missing choices that lie between
569 -- the explicit ones given in the case.
571 for J
in 2 .. Case_Table
'Last loop
572 Lo
:= Expr_Value
(Case_Table
(J
).Lo
);
573 Hi
:= Expr_Value
(Case_Table
(J
).Hi
);
575 if Lo
/= (Previous_Hi
+ 1) then
576 Append_To
(Choice_List
, Build_Choice
(Previous_Hi
+ 1, Lo
- 1));
582 -- Build the node for any missing choices that are greater than any
583 -- explicit choices given in the case.
585 if Expr_Value
(Exp_Hi
) > Hi
then
586 Append
(Build_Choice
(Hi
+ 1, Expr_Value
(Exp_Hi
)), Choice_List
);
589 Set_Others_Discrete_Choices
(Others_Choice
, Choice_List
);
591 -- Warn on null others list if warning option set
593 if Warn_On_Redundant_Constructs
594 and then Comes_From_Source
(Others_Choice
)
595 and then Is_Empty_List
(Choice_List
)
597 Error_Msg_N
("?OTHERS choice is redundant", Others_Choice
);
598 Error_Msg_N
("\previous choices cover all values", Others_Choice
);
600 end Expand_Others_Choice
;
606 procedure No_OP
(C
: Node_Id
) is
607 pragma Warnings
(Off
, C
);
612 --------------------------------
613 -- Generic_Choices_Processing --
614 --------------------------------
616 package body Generic_Choices_Processing
is
618 -- The following type is used to gather the entries for the choice
619 -- table, so that we can then allocate the right length.
622 type Link_Ptr
is access all Link
;
629 procedure Free
is new Ada
.Unchecked_Deallocation
(Link
, Link_Ptr
);
631 ---------------------
632 -- Analyze_Choices --
633 ---------------------
635 procedure Analyze_Choices
638 Raises_CE
: out Boolean;
639 Others_Present
: out Boolean)
644 -- This is where we post error messages for bounds out of range
646 Choice_List
: Link_Ptr
:= null;
647 -- Gather list of choices
649 Num_Choices
: Nat
:= 0;
650 -- Number of entries in Choice_List
652 Choice_Type
: constant Entity_Id
:= Base_Type
(Subtyp
);
653 -- The actual type against which the discrete choices are resolved.
654 -- Note that this type is always the base type not the subtype of the
655 -- ruling expression, index or discriminant.
657 Bounds_Type
: Entity_Id
;
658 -- The type from which are derived the bounds of the values covered
659 -- by the discrete choices (see 3.8.1 (4)). If a discrete choice
660 -- specifies a value outside of these bounds we have an error.
664 -- The actual bounds of the above type
666 Expected_Type
: Entity_Id
;
667 -- The expected type of each choice. Equal to Choice_Type, except if
668 -- the expression is universal, in which case the choices can be of
672 -- A case statement alternative or a variant in a record type
677 -- The node kind of the current Choice
679 Delete_Choice
: Boolean;
680 -- Set to True to delete the current choice
682 Others_Choice
: Node_Id
:= Empty
;
683 -- Remember others choice if it is present (empty otherwise)
685 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
);
686 -- Checks the validity of the bounds of a choice. When the bounds
687 -- are static and no error occurred the bounds are collected for
688 -- later entry into the choices table so that they can be sorted
695 procedure Check
(Choice
: Node_Id
; Lo
, Hi
: Node_Id
) is
700 -- First check if an error was already detected on either bounds
702 if Etype
(Lo
) = Any_Type
or else Etype
(Hi
) = Any_Type
then
705 -- Do not insert non static choices in the table to be sorted
707 elsif not Is_Static_Expression
(Lo
)
708 or else not Is_Static_Expression
(Hi
)
710 Process_Non_Static_Choice
(Choice
);
713 -- Ignore range which raise constraint error
715 elsif Raises_Constraint_Error
(Lo
)
716 or else Raises_Constraint_Error
(Hi
)
721 -- Otherwise we have an OK static choice
724 Lo_Val
:= Expr_Value
(Lo
);
725 Hi_Val
:= Expr_Value
(Hi
);
727 -- Do not insert null ranges in the choices table
729 if Lo_Val
> Hi_Val
then
730 Process_Empty_Choice
(Choice
);
735 -- Check for low bound out of range
737 if Lo_Val
< Bounds_Lo
then
739 -- If the choice is an entity name, then it is a type, and we
740 -- want to post the message on the reference to this entity.
741 -- Otherwise post it on the lower bound of the range.
743 if Is_Entity_Name
(Choice
) then
749 -- Specialize message for integer/enum type
751 if Is_Integer_Type
(Bounds_Type
) then
752 Error_Msg_Uint_1
:= Bounds_Lo
;
753 Error_Msg_N
("minimum allowed choice value is^", Enode
);
755 Error_Msg_Name_1
:= Choice_Image
(Bounds_Lo
, Bounds_Type
);
756 Error_Msg_N
("minimum allowed choice value is%", Enode
);
760 -- Check for high bound out of range
762 if Hi_Val
> Bounds_Hi
then
764 -- If the choice is an entity name, then it is a type, and we
765 -- want to post the message on the reference to this entity.
766 -- Otherwise post it on the upper bound of the range.
768 if Is_Entity_Name
(Choice
) then
774 -- Specialize message for integer/enum type
776 if Is_Integer_Type
(Bounds_Type
) then
777 Error_Msg_Uint_1
:= Bounds_Hi
;
778 Error_Msg_N
("maximum allowed choice value is^", Enode
);
780 Error_Msg_Name_1
:= Choice_Image
(Bounds_Hi
, Bounds_Type
);
781 Error_Msg_N
("maximum allowed choice value is%", Enode
);
785 -- Collect bounds in the list
787 -- Note: we still store the bounds, even if they are out of range,
788 -- since this may prevent unnecessary cascaded errors for values
789 -- that are covered by such an excessive range.
792 new Link
'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
793 Num_Choices := Num_Choices + 1;
796 -- Start of processing for Analyze_Choices
800 Others_Present := False;
802 -- If Subtyp is not a static subtype Ada 95 requires then we use the
803 -- bounds of its base type to determine the values covered by the
806 if Is_OK_Static_Subtype (Subtyp) then
807 Bounds_Type := Subtyp;
809 Bounds_Type := Choice_Type;
812 -- Obtain static bounds of type, unless this is a generic formal
813 -- discrete type for which all choices will be non-static.
815 if not Is_Generic_Type (Root_Type (Bounds_Type))
816 or else Ekind (Bounds_Type) /= E_Enumeration_Type
818 Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
819 Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
822 if Choice_Type = Universal_Integer then
823 Expected_Type := Any_Integer;
825 Expected_Type := Choice_Type;
828 -- Now loop through the case alternatives or record variants
830 Alt := First (Get_Alternatives (N));
831 while Present (Alt) loop
833 -- If pragma, just analyze it
835 if Nkind (Alt) = N_Pragma then
838 -- Otherwise check each choice against its base type
841 Choice := First (Get_Choices (Alt));
842 while Present (Choice) loop
843 Delete_Choice := False;
845 Kind := Nkind (Choice);
850 or else (Kind = N_Attribute_Reference
851 and then Attribute_Name (Choice) = Name_Range)
853 Resolve (Choice, Expected_Type);
854 Check (Choice, Low_Bound (Choice), High_Bound (Choice));
856 -- Choice is a subtype name
858 elsif Is_Entity_Name (Choice)
859 and then Is_Type (Entity (Choice))
861 if not Covers (Expected_Type, Etype (Choice)) then
862 Wrong_Type (Choice, Choice_Type);
865 E := Entity (Choice);
867 -- Case of predicated subtype
869 if Has_Predicates (E) then
871 -- Use of non-static predicate is an error
873 if not Is_Discrete_Type (E)
874 or else No (Static_Predicate (E))
876 Bad_Predicated_Subtype_Use
877 ("cannot use subtype& with non-static "
878 & "predicate as case alternative", Choice, E);
880 -- Static predicate case
884 Copy : constant List_Id := Empty_List;
889 -- Loop through entries in predicate list,
890 -- converting to choices. Note that if the
891 -- list is empty, corresponding to a False
892 -- predicate, then no choices are inserted.
894 P := First (Static_Predicate (E));
895 while Present (P) loop
897 Set_Sloc (C, Sloc (Choice));
902 Insert_List_After (Choice, Copy);
903 Delete_Choice := True;
907 -- Not predicated subtype case
909 elsif not Is_Static_Subtype (E) then
910 Process_Non_Static_Choice (Choice);
913 (Choice, Type_Low_Bound (E), Type_High_Bound (E));
917 -- Choice is a subtype indication
919 elsif Kind = N_Subtype_Indication then
920 Resolve_Discrete_Subtype_Indication
921 (Choice, Expected_Type);
923 -- Here for other than predicated subtype case
925 if Etype (Choice) /= Any_Type then
927 C : constant Node_Id := Constraint (Choice);
928 R : constant Node_Id := Range_Expression (C);
929 L : constant Node_Id := Low_Bound (R);
930 H : constant Node_Id := High_Bound (R);
933 E := Entity (Subtype_Mark (Choice));
935 if not Is_Static_Subtype (E) then
936 Process_Non_Static_Choice (Choice);
939 if Is_OK_Static_Expression (L)
940 and then Is_OK_Static_Expression (H)
942 if Expr_Value (L) > Expr_Value (H) then
943 Process_Empty_Choice (Choice);
945 if Is_Out_Of_Range (L, E) then
946 Apply_Compile_Time_Constraint_Error
947 (L, "static value out of range",
948 CE_Range_Check_Failed);
951 if Is_Out_Of_Range (H, E) then
952 Apply_Compile_Time_Constraint_Error
953 (H, "static value out of range",
954 CE_Range_Check_Failed);
959 Check (Choice, L, H);
964 -- The others choice is only allowed for the last
965 -- alternative and as its only choice.
967 elsif Kind = N_Others_Choice then
968 if not (Choice = First (Get_Choices (Alt))
969 and then Choice = Last (Get_Choices (Alt))
970 and then Alt = Last (Get_Alternatives (N)))
973 ("the choice OTHERS must appear alone and last",
978 Others_Present := True;
979 Others_Choice := Choice;
981 -- Only other possibility is an expression
984 Resolve (Choice, Expected_Type);
985 Check (Choice, Choice, Choice);
988 -- Move to next choice, deleting the current one if the
989 -- flag requesting this deletion is set True.
992 C : constant Node_Id := Choice;
996 if Delete_Choice then
1002 Process_Associated_Node (Alt);
1008 -- Now we can create the Choice_Table, since we know how long
1009 -- it needs to be so we can allocate exactly the right length.
1012 Choice_Table : Choice_Table_Type (0 .. Num_Choices);
1015 -- Now copy the items we collected in the linked list into this
1016 -- newly allocated table (leave entry 0 unused for sorting).
1021 for J in 1 .. Num_Choices loop
1023 Choice_List := T.Nxt;
1024 Choice_Table (J) := T.Val;
1033 Others_Present or else (Choice_Type = Universal_Integer),
1036 -- If no others choice we are all done, otherwise we have one more
1037 -- step, which is to set the Others_Discrete_Choices field of the
1038 -- others choice (to contain all otherwise unspecified choices).
1039 -- Skip this if CE is known to be raised.
1041 if Others_Present and not Raises_CE then
1042 Expand_Others_Choice
1043 (Case_Table => Choice_Table,
1044 Others_Choice => Others_Choice,
1045 Choice_Type => Bounds_Type);
1048 end Analyze_Choices;
1050 end Generic_Choices_Processing;