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;