diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/sem_case.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/sem_case.adb | 1617 |
1 files changed, 1617 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/sem_case.adb b/gcc-4.9/gcc/ada/sem_case.adb new file mode 100644 index 000000000..b3f47a6df --- /dev/null +++ b/gcc-4.9/gcc/ada/sem_case.adb @@ -0,0 +1,1617 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ C A S E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Eval; use Sem_Eval; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Snames; use Snames; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +with Ada.Unchecked_Deallocation; + +with GNAT.Heap_Sort_G; + +package body Sem_Case is + + type Choice_Bounds is record + Lo : Node_Id; + Hi : Node_Id; + Node : Node_Id; + end record; + -- Represent one choice bounds entry with Lo and Hi values, Node points + -- to the choice node itself. + + type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; + -- Table type used to sort the choices present in a case statement or + -- record variant. The actual entries are stored in 1 .. Last, but we + -- have a 0 entry for use in sorting. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Choice_Set + (Choice_Table : in out Choice_Table_Type; + Bounds_Type : Entity_Id; + Subtyp : Entity_Id; + Others_Present : Boolean; + Case_Node : Node_Id); + -- This is the procedure which verifies that a set of case alternatives + -- or record variant choices has no duplicates, and covers the range + -- specified by Bounds_Type. Choice_Table contains the discrete choices + -- to check. These must start at position 1. + -- + -- Furthermore Choice_Table (0) must exist. This element is used by + -- the sorting algorithm as a temporary. Others_Present is a flag + -- indicating whether or not an Others choice is present. Finally + -- Msg_Sloc gives the source location of the construct containing the + -- choices in the Choice_Table. + -- + -- Bounds_Type is the type whose range must be covered by the alternatives + -- + -- Subtyp is the subtype of the expression. If its bounds are non-static + -- the alternatives must cover its base type. + + function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; + -- Given a Pos value of enumeration type Ctype, returns the name + -- ID of an appropriate string to be used in error message output. + + procedure Expand_Others_Choice + (Case_Table : Choice_Table_Type; + Others_Choice : Node_Id; + Choice_Type : Entity_Id); + -- The case table is the table generated by a call to Check_Choices + -- (with just 1 .. Last_Choice entries present). Others_Choice is a + -- pointer to the N_Others_Choice node (this routine is only called if + -- an others choice is present), and Choice_Type is the discrete type + -- of the bounds. The effect of this call is to analyze the cases and + -- determine the set of values covered by others. This choice list is + -- set in the Others_Discrete_Choices field of the N_Others_Choice node. + + ---------------------- + -- Check_Choice_Set -- + ---------------------- + + procedure Check_Choice_Set + (Choice_Table : in out Choice_Table_Type; + Bounds_Type : Entity_Id; + Subtyp : Entity_Id; + Others_Present : Boolean; + Case_Node : Node_Id) + is + procedure Check_Against_Predicate + (Pred : in out Node_Id; + Choice : Choice_Bounds; + Prev_Lo : in out Uint; + Prev_Hi : in out Uint; + Error : in out Boolean); + -- Determine whether a choice covers legal values as defined by a static + -- predicate set. Pred is a static predicate range. Choice is the choice + -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous + -- choice that covered a predicate set. Error denotes whether the check + -- found an illegal intersection. + + procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); + -- Post message "duplication of choice value(s) bla bla at xx". Message + -- is posted at location C. Caller sets Error_Msg_Sloc for xx. + + procedure Explain_Non_Static_Bound; + -- Called when we find a non-static bound, requiring the base type to + -- be covered. Provides where possible a helpful explanation of why the + -- bounds are non-static, since this is not always obvious. + + function Lt_Choice (C1, C2 : Natural) return Boolean; + -- Comparison routine for comparing Choice_Table entries. Use the lower + -- bound of each Choice as the key. + + procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id); + procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint); + procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id); + procedure Missing_Choice (Value1 : Uint; Value2 : Uint); + -- Issue an error message indicating that there are missing choices, + -- followed by the image of the missing choices themselves which lie + -- between Value1 and Value2 inclusive. + + procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint); + -- Emit an error message for each non-covered static predicate set. + -- Prev_Hi denotes the upper bound of the last choice covering a set. + + procedure Move_Choice (From : Natural; To : Natural); + -- Move routine for sorting the Choice_Table + + package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); + + ----------------------------- + -- Check_Against_Predicate -- + ----------------------------- + + procedure Check_Against_Predicate + (Pred : in out Node_Id; + Choice : Choice_Bounds; + Prev_Lo : in out Uint; + Prev_Hi : in out Uint; + Error : in out Boolean) + is + procedure Illegal_Range + (Loc : Source_Ptr; + Lo : Uint; + Hi : Uint); + -- Emit an error message regarding a choice that clashes with the + -- legal static predicate sets. Loc is the location of the choice + -- that introduced the illegal range. Lo .. Hi is the range. + + function Inside_Range + (Lo : Uint; + Hi : Uint; + Val : Uint) return Boolean; + -- Determine whether position Val within a discrete type is within + -- the range Lo .. Hi inclusive. + + ------------------- + -- Illegal_Range -- + ------------------- + + procedure Illegal_Range + (Loc : Source_Ptr; + Lo : Uint; + Hi : Uint) + is + begin + Error_Msg_Name_1 := Chars (Bounds_Type); + + -- Single value + + if Lo = Hi then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg ("static predicate on % excludes value ^!", Loc); + else + Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); + Error_Msg ("static predicate on % excludes value %!", Loc); + end if; + + -- Range + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; + Error_Msg + ("static predicate on % excludes range ^ .. ^!", Loc); + else + Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); + Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type); + Error_Msg + ("static predicate on % excludes range % .. %!", Loc); + end if; + end if; + end Illegal_Range; + + ------------------ + -- Inside_Range -- + ------------------ + + function Inside_Range + (Lo : Uint; + Hi : Uint; + Val : Uint) return Boolean + is + begin + return + Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi); + end Inside_Range; + + -- Local variables + + Choice_Hi : constant Uint := Expr_Value (Choice.Hi); + Choice_Lo : constant Uint := Expr_Value (Choice.Lo); + Loc : Source_Ptr; + LocN : Node_Id; + Next_Hi : Uint; + Next_Lo : Uint; + Pred_Hi : Uint; + Pred_Lo : Uint; + + -- Start of processing for Check_Against_Predicate + + begin + -- Find the proper error message location + + if Present (Choice.Node) then + LocN := Choice.Node; + else + LocN := Case_Node; + end if; + + Loc := Sloc (LocN); + + if Present (Pred) then + Pred_Lo := Expr_Value (Low_Bound (Pred)); + Pred_Hi := Expr_Value (High_Bound (Pred)); + + -- Previous choices managed to satisfy all static predicate sets + + else + Illegal_Range (Loc, Choice_Lo, Choice_Hi); + Error := True; + return; + end if; + + -- Step 1: Detect duplicate choices + + if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then + Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN); + Error := True; + + elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then + Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN); + Error := True; + + -- Step 2: Detect full coverage + + -- Choice_Lo Choice_Hi + -- +============+ + -- Pred_Lo Pred_Hi + + elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + Next (Pred); + + -- Step 3: Detect all cases where a choice mentions values that are + -- not part of the static predicate sets. + + -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi + -- +-----------+ . . . . . +=========+ + -- ^ illegal ^ + + elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then + Illegal_Range (Loc, Choice_Lo, Choice_Hi); + Error := True; + + -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi + -- +-----------+=========+===========+ + -- ^ illegal ^ + + elsif Choice_Lo < Pred_Lo + and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi) + then + Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); + Error := True; + + -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi + -- +=========+ . . . . +-----------+ + -- ^ illegal ^ + + elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then + if Others_Present then + + -- Current predicate set is covered by others clause. + + null; + + else + Missing_Choice (Pred_Lo, Pred_Hi); + Error := True; + end if; + + -- There may be several static predicate sets between the current + -- one and the choice. Inspect the next static predicate set. + + Next (Pred); + Check_Against_Predicate + (Pred => Pred, + Choice => Choice, + Prev_Lo => Prev_Lo, + Prev_Hi => Prev_Hi, + Error => Error); + + -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi + -- +=========+===========+-----------+ + -- ^ illegal ^ + + elsif Pred_Hi < Choice_Hi + and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo) + then + Next (Pred); + + -- The choice may fall in a static predicate set. If this is the + -- case, avoid mentioning legal values in the error message. + + if Present (Pred) then + Next_Lo := Expr_Value (Low_Bound (Pred)); + Next_Hi := Expr_Value (High_Bound (Pred)); + + -- The next static predicate set is to the right of the choice + + if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then + Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); + else + Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1); + end if; + else + Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); + end if; + + Error := True; + + -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi + -- +-----------+=========+-----------+ + -- ^ illegal ^ ^ illegal ^ + + -- Emit an error on the low gap, disregard the upper gap + + elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then + Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); + Error := True; + + -- Step 4: Detect all cases of partial or missing coverage + + -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi + -- +=========+==========+===========+ + -- ^ gap ^ ^ gap ^ + + else + -- An "others" choice covers all gaps + + if Others_Present then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + + -- Check whether predicate set is fully covered by choice + + if Pred_Hi = Choice_Hi then + Next (Pred); + end if; + + -- Choice_Lo Choice_Hi Pred_Hi + -- +===========+===========+ + -- Pred_Lo ^ gap ^ + + -- The upper gap may be covered by a subsequent choice + + elsif Pred_Lo = Choice_Lo then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + + -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi + -- +===========+=========+===========+===========+ + -- ^ covered ^ ^ gap ^ + + else pragma Assert (Pred_Lo < Choice_Lo); + + -- A previous choice covered the gap up to the current choice + + if Prev_Hi = Choice_Lo - 1 then + Prev_Lo := Choice_Lo; + Prev_Hi := Choice_Hi; + + if Choice_Hi = Pred_Hi then + Next (Pred); + end if; + + -- The previous choice did not intersect with the current + -- static predicate set. + + elsif Prev_Hi < Pred_Lo then + Missing_Choice (Pred_Lo, Choice_Lo - 1); + Error := True; + + -- The previous choice covered part of the static predicate set + + else + Missing_Choice (Prev_Hi, Choice_Lo - 1); + Error := True; + end if; + end if; + end if; + end Check_Against_Predicate; + + ---------------- + -- Dup_Choice -- + ---------------- + + procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is + begin + -- In some situations, we call this with a null range, and obviously + -- we don't want to complain in this case. + + if Lo > Hi then + return; + end if; + + -- Case of only one value that is missing + + if Lo = Hi then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_N ("duplication of choice value: ^#!", C); + else + Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); + Error_Msg_N ("duplication of choice value: %#!", C); + end if; + + -- More than one choice value, so print range of values + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; + Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); + else + Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); + Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); + Error_Msg_N ("duplication of choice values: % .. %#!", C); + end if; + end if; + end Dup_Choice; + + ------------------------------ + -- Explain_Non_Static_Bound -- + ------------------------------ + + procedure Explain_Non_Static_Bound is + Expr : Node_Id; + + begin + if Nkind (Case_Node) = N_Variant_Part then + Expr := Name (Case_Node); + else + Expr := Expression (Case_Node); + end if; + + if Bounds_Type /= Subtyp then + + -- If the case is a variant part, the expression is given by the + -- discriminant itself, and the bounds are the culprits. + + if Nkind (Case_Node) = N_Variant_Part then + Error_Msg_NE + ("bounds of & are not static, " + & "alternatives must cover base type!", Expr, Expr); + + -- If this is a case statement, the expression may be non-static + -- or else the subtype may be at fault. + + elsif Is_Entity_Name (Expr) then + Error_Msg_NE + ("bounds of & are not static, " + & "alternatives must cover base type!", Expr, Expr); + + else + Error_Msg_N + ("subtype of expression is not static, " + & "alternatives must cover base type!", Expr); + end if; + + -- Otherwise the expression is not static, even if the bounds of the + -- type are, or else there are missing alternatives. If both, the + -- additional information may be redundant but harmless. + + elsif not Is_Entity_Name (Expr) then + Error_Msg_N + ("subtype of expression is not static, " + & "alternatives must cover base type!", Expr); + end if; + end Explain_Non_Static_Bound; + + --------------- + -- Lt_Choice -- + --------------- + + function Lt_Choice (C1, C2 : Natural) return Boolean is + begin + return + Expr_Value (Choice_Table (Nat (C1)).Lo) + < + Expr_Value (Choice_Table (Nat (C2)).Lo); + end Lt_Choice; + + -------------------- + -- Missing_Choice -- + -------------------- + + procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is + begin + Missing_Choice (Expr_Value (Value1), Expr_Value (Value2)); + end Missing_Choice; + + procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is + begin + Missing_Choice (Expr_Value (Value1), Value2); + end Missing_Choice; + + procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is + begin + Missing_Choice (Value1, Expr_Value (Value2)); + end Missing_Choice; + + procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is + Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); + + begin + -- AI05-0188 : within an instance the non-others choices do not have + -- to belong to the actual subtype. + + if Ada_Version >= Ada_2012 and then In_Instance then + return; + + -- In some situations, we call this with a null range, and obviously + -- we don't want to complain in this case. + + elsif Value1 > Value2 then + return; + end if; + + -- Case of only one value that is missing + + if Value1 = Value2 then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Value1; + Error_Msg ("missing case value: ^!", Msg_Sloc); + else + Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); + Error_Msg ("missing case value: %!", Msg_Sloc); + end if; + + -- More than one choice value, so print range of values + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Value1; + Error_Msg_Uint_2 := Value2; + Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); + else + Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); + Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); + Error_Msg ("missing case values: % .. %!", Msg_Sloc); + end if; + end if; + end Missing_Choice; + + --------------------- + -- Missing_Choices -- + --------------------- + + procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is + Hi : Uint; + Lo : Uint; + Set : Node_Id; + + begin + Set := Pred; + while Present (Set) loop + Lo := Expr_Value (Low_Bound (Set)); + Hi := Expr_Value (High_Bound (Set)); + + -- A choice covered part of a static predicate set + + if Lo <= Prev_Hi and then Prev_Hi < Hi then + Missing_Choice (Prev_Hi + 1, Hi); + + else + Missing_Choice (Lo, Hi); + end if; + + Next (Set); + end loop; + end Missing_Choices; + + ----------------- + -- Move_Choice -- + ----------------- + + procedure Move_Choice (From : Natural; To : Natural) is + begin + Choice_Table (Nat (To)) := Choice_Table (Nat (From)); + end Move_Choice; + + -- Local variables + + Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); + Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); + Has_Predicate : constant Boolean := + Is_Static_Subtype (Bounds_Type) + and then Present (Static_Predicate (Bounds_Type)); + Num_Choices : constant Nat := Choice_Table'Last; + + Choice : Node_Id; + Choice_Hi : Uint; + Choice_Lo : Uint; + Error : Boolean; + Pred : Node_Id; + Prev_Choice : Node_Id; + Prev_Lo : Uint; + Prev_Hi : Uint; + + -- Start of processing for Check_Choice_Set + + begin + -- Choice_Table must start at 0 which is an unused location used by the + -- sorting algorithm. However the first valid position for a discrete + -- choice is 1. + + pragma Assert (Choice_Table'First = 0); + + -- The choices do not cover the base range. Emit an error if "others" is + -- not available and return as there is no need for further processing. + + if Num_Choices = 0 then + if not Others_Present then + Missing_Choice (Bounds_Lo, Bounds_Hi); + end if; + + return; + end if; + + Sorting.Sort (Positive (Choice_Table'Last)); + + -- The type covered by the list of choices is actually a static subtype + -- subject to a static predicate. The predicate defines subsets of legal + -- values and requires finer grained analysis. + + if Has_Predicate then + Pred := First (Static_Predicate (Bounds_Type)); + Prev_Lo := Uint_Minus_1; + Prev_Hi := Uint_Minus_1; + Error := False; + + for Index in 1 .. Num_Choices loop + Check_Against_Predicate + (Pred => Pred, + Choice => Choice_Table (Index), + Prev_Lo => Prev_Lo, + Prev_Hi => Prev_Hi, + Error => Error); + + -- The analysis detected an illegal intersection between a choice + -- and a static predicate set. + + if Error then + return; + end if; + end loop; + + -- The choices may legally cover some of the static predicate sets, + -- but not all. Emit an error for each non-covered set. + + if not Others_Present then + Missing_Choices (Pred, Prev_Hi); + end if; + + -- Default analysis + + else + Choice_Lo := Expr_Value (Choice_Table (1).Lo); + Choice_Hi := Expr_Value (Choice_Table (1).Hi); + Prev_Hi := Choice_Hi; + + if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then + Missing_Choice (Bounds_Lo, Choice_Lo - 1); + + -- If values are missing outside of the subtype, add explanation. + -- No additional message if only one value is missing. + + if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then + Explain_Non_Static_Bound; + end if; + end if; + + for Outer_Index in 2 .. Num_Choices loop + Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); + Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); + + if Choice_Lo <= Prev_Hi then + Choice := Choice_Table (Outer_Index).Node; + + -- Find first previous choice that overlaps + + for Inner_Index in 1 .. Outer_Index - 1 loop + if Choice_Lo <= + Expr_Value (Choice_Table (Inner_Index).Hi) + then + Prev_Choice := Choice_Table (Inner_Index).Node; + exit; + end if; + end loop; + + if Sloc (Prev_Choice) <= Sloc (Choice) then + Error_Msg_Sloc := Sloc (Prev_Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); + else + Error_Msg_Sloc := Sloc (Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); + end if; + + elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then + Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); + end if; + + if Choice_Hi > Prev_Hi then + Prev_Hi := Choice_Hi; + end if; + end loop; + + if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then + Missing_Choice (Prev_Hi + 1, Bounds_Hi); + + if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then + Explain_Non_Static_Bound; + end if; + end if; + end if; + end Check_Choice_Set; + + ------------------ + -- Choice_Image -- + ------------------ + + function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is + Rtp : constant Entity_Id := Root_Type (Ctype); + Lit : Entity_Id; + C : Int; + + begin + -- For character, or wide [wide] character. If 7-bit ASCII graphic + -- range, then build and return appropriate character literal name + + if Is_Standard_Character_Type (Ctype) then + C := UI_To_Int (Value); + + if C in 16#20# .. 16#7E# then + Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); + return Name_Find; + end if; + + -- For user defined enumeration type, find enum/char literal + + else + Lit := First_Literal (Rtp); + + for J in 1 .. UI_To_Int (Value) loop + Next_Literal (Lit); + end loop; + + -- If enumeration literal, just return its value + + if Nkind (Lit) = N_Defining_Identifier then + return Chars (Lit); + + -- For character literal, get the name and use it if it is + -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. + + else + Get_Decoded_Name_String (Chars (Lit)); + + if Name_Len = 3 + and then Name_Buffer (2) in + Character'Val (16#20#) .. Character'Val (16#7E#) + then + return Chars (Lit); + end if; + end if; + end if; + + -- If we fall through, we have a character literal which is not in + -- the 7-bit ASCII graphic set. For such cases, we construct the + -- name "type'val(nnn)" where type is the choice type, and nnn is + -- the pos value passed as an argument to Choice_Image. + + Get_Name_String (Chars (First_Subtype (Ctype))); + + Add_Str_To_Name_Buffer ("'val("); + UI_Image (Value); + Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); + Add_Char_To_Name_Buffer (')'); + return Name_Find; + end Choice_Image; + + -------------------------- + -- Expand_Others_Choice -- + -------------------------- + + procedure Expand_Others_Choice + (Case_Table : Choice_Table_Type; + Others_Choice : Node_Id; + Choice_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Others_Choice); + Choice_List : constant List_Id := New_List; + Choice : Node_Id; + Exp_Lo : Node_Id; + Exp_Hi : Node_Id; + Hi : Uint; + Lo : Uint; + Previous_Hi : Uint; + + function Build_Choice (Value1, Value2 : Uint) return Node_Id; + -- Builds a node representing the missing choices given by Value1 and + -- Value2. A N_Range node is built if there is more than one literal + -- value missing. Otherwise a single N_Integer_Literal, N_Identifier + -- or N_Character_Literal is built depending on what Choice_Type is. + + function Lit_Of (Value : Uint) return Node_Id; + -- Returns the Node_Id for the enumeration literal corresponding to the + -- position given by Value within the enumeration type Choice_Type. + + ------------------ + -- Build_Choice -- + ------------------ + + function Build_Choice (Value1, Value2 : Uint) return Node_Id is + Lit_Node : Node_Id; + Lo, Hi : Node_Id; + + begin + -- If there is only one choice value missing between Value1 and + -- Value2, build an integer or enumeration literal to represent it. + + if (Value2 - Value1) = 0 then + if Is_Integer_Type (Choice_Type) then + Lit_Node := Make_Integer_Literal (Loc, Value1); + Set_Etype (Lit_Node, Choice_Type); + else + Lit_Node := Lit_Of (Value1); + end if; + + -- Otherwise is more that one choice value that is missing between + -- Value1 and Value2, therefore build a N_Range node of either + -- integer or enumeration literals. + + else + if Is_Integer_Type (Choice_Type) then + Lo := Make_Integer_Literal (Loc, Value1); + Set_Etype (Lo, Choice_Type); + Hi := Make_Integer_Literal (Loc, Value2); + Set_Etype (Hi, Choice_Type); + Lit_Node := + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); + + else + Lit_Node := + Make_Range (Loc, + Low_Bound => Lit_Of (Value1), + High_Bound => Lit_Of (Value2)); + end if; + end if; + + return Lit_Node; + end Build_Choice; + + ------------ + -- Lit_Of -- + ------------ + + function Lit_Of (Value : Uint) return Node_Id is + Lit : Entity_Id; + + begin + -- In the case where the literal is of type Character, there needs + -- to be some special handling since there is no explicit chain + -- of literals to search. Instead, a N_Character_Literal node + -- is created with the appropriate Char_Code and Chars fields. + + if Is_Standard_Character_Type (Choice_Type) then + Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); + Lit := New_Node (N_Character_Literal, Loc); + Set_Chars (Lit, Name_Find); + Set_Char_Literal_Value (Lit, Value); + Set_Etype (Lit, Choice_Type); + Set_Is_Static_Expression (Lit, True); + return Lit; + + -- Otherwise, iterate through the literals list of Choice_Type + -- "Value" number of times until the desired literal is reached + -- and then return an occurrence of it. + + else + Lit := First_Literal (Choice_Type); + for J in 1 .. UI_To_Int (Value) loop + Next_Literal (Lit); + end loop; + + return New_Occurrence_Of (Lit, Loc); + end if; + end Lit_Of; + + -- Start of processing for Expand_Others_Choice + + begin + if Case_Table'Last = 0 then + + -- Special case: only an others case is present. The others case + -- covers the full range of the type. + + if Is_Static_Subtype (Choice_Type) then + Choice := New_Occurrence_Of (Choice_Type, Loc); + else + Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); + end if; + + Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); + return; + end if; + + -- Establish the bound values for the choice depending upon whether the + -- type of the case statement is static or not. + + if Is_OK_Static_Subtype (Choice_Type) then + Exp_Lo := Type_Low_Bound (Choice_Type); + Exp_Hi := Type_High_Bound (Choice_Type); + else + Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); + Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); + end if; + + Lo := Expr_Value (Case_Table (1).Lo); + Hi := Expr_Value (Case_Table (1).Hi); + Previous_Hi := Expr_Value (Case_Table (1).Hi); + + -- Build the node for any missing choices that are smaller than any + -- explicit choices given in the case. + + if Expr_Value (Exp_Lo) < Lo then + Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); + end if; + + -- Build the nodes representing any missing choices that lie between + -- the explicit ones given in the case. + + for J in 2 .. Case_Table'Last loop + Lo := Expr_Value (Case_Table (J).Lo); + Hi := Expr_Value (Case_Table (J).Hi); + + if Lo /= (Previous_Hi + 1) then + Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); + end if; + + Previous_Hi := Hi; + end loop; + + -- Build the node for any missing choices that are greater than any + -- explicit choices given in the case. + + if Expr_Value (Exp_Hi) > Hi then + Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); + end if; + + Set_Others_Discrete_Choices (Others_Choice, Choice_List); + + -- Warn on null others list if warning option set + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (Others_Choice) + and then Is_Empty_List (Choice_List) + then + Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice); + Error_Msg_N ("\?r?previous choices cover all values", Others_Choice); + end if; + end Expand_Others_Choice; + + ----------- + -- No_OP -- + ----------- + + procedure No_OP (C : Node_Id) is + pragma Warnings (Off, C); + begin + null; + end No_OP; + + ----------------------------- + -- Generic_Analyze_Choices -- + ----------------------------- + + package body Generic_Analyze_Choices is + + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + --------------------- + -- Analyze_Choices -- + --------------------- + + procedure Analyze_Choices + (Alternatives : List_Id; + Subtyp : Entity_Id) + is + Choice_Type : constant Entity_Id := Base_Type (Subtyp); + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. + + Expected_Type : Entity_Id; + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. + + Alt : Node_Id; + -- A case statement alternative or a variant in a record type + -- declaration. + + Choice : Node_Id; + Kind : Node_Kind; + -- The node kind of the current Choice + + begin + -- Set Expected type (= choice type except for universal integer, + -- where we accept any integer type as a choice). + + if Choice_Type = Universal_Integer then + Expected_Type := Any_Integer; + else + Expected_Type := Choice_Type; + end if; + + -- Now loop through the case alternatives or record variants + + Alt := First (Alternatives); + while Present (Alt) loop + + -- If pragma, just analyze it + + if Nkind (Alt) = N_Pragma then + Analyze (Alt); + + -- Otherwise we have an alternative. In most cases the semantic + -- processing leaves the list of choices unchanged + + -- Check each choice against its base type + + else + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop + Analyze (Choice); + Kind := Nkind (Choice); + + -- Choice is a Range + + if Kind = N_Range + or else (Kind = N_Attribute_Reference + and then Attribute_Name (Choice) = Name_Range) + then + Resolve (Choice, Expected_Type); + + -- Choice is a subtype name, nothing further to do now + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + null; + + -- Choice is a subtype indication + + elsif Kind = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication + (Choice, Expected_Type); + + -- Others choice, no analysis needed + + elsif Kind = N_Others_Choice then + null; + + -- Only other possibility is an expression + + else + Resolve (Choice, Expected_Type); + end if; + + -- Move to next choice + + Next (Choice); + end loop; + + Process_Associated_Node (Alt); + end if; + + Next (Alt); + end loop; + end Analyze_Choices; + + end Generic_Analyze_Choices; + + --------------------------- + -- Generic_Check_Choices -- + --------------------------- + + package body Generic_Check_Choices is + + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); + + ------------------- + -- Check_Choices -- + ------------------- + + procedure Check_Choices + (N : Node_Id; + Alternatives : List_Id; + Subtyp : Entity_Id; + Others_Present : out Boolean) + is + E : Entity_Id; + + Raises_CE : Boolean; + -- Set True if one of the bounds of a choice raises CE + + Enode : Node_Id; + -- This is where we post error messages for bounds out of range + + Choice_List : Link_Ptr := null; + -- Gather list of choices + + Num_Choices : Nat := 0; + -- Number of entries in Choice_List + + Choice_Type : constant Entity_Id := Base_Type (Subtyp); + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. + + Bounds_Type : Entity_Id; + -- The type from which are derived the bounds of the values covered + -- by the discrete choices (see 3.8.1 (4)). If a discrete choice + -- specifies a value outside of these bounds we have an error. + + Bounds_Lo : Uint; + Bounds_Hi : Uint; + -- The actual bounds of the above type + + Expected_Type : Entity_Id; + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. + + Alt : Node_Id; + -- A case statement alternative or a variant in a record type + -- declaration. + + Choice : Node_Id; + Kind : Node_Kind; + -- The node kind of the current Choice + + Others_Choice : Node_Id := Empty; + -- Remember others choice if it is present (empty otherwise) + + procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); + -- Checks the validity of the bounds of a choice. When the bounds + -- are static and no error occurred the bounds are collected for + -- later entry into the choices table so that they can be sorted + -- later on. + + ----------- + -- Check -- + ----------- + + procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is + Lo_Val : Uint; + Hi_Val : Uint; + + begin + -- First check if an error was already detected on either bounds + + if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then + return; + + -- Do not insert non static choices in the table to be sorted + + elsif not Is_Static_Expression (Lo) + or else + not Is_Static_Expression (Hi) + then + Process_Non_Static_Choice (Choice); + return; + + -- Ignore range which raise constraint error + + elsif Raises_Constraint_Error (Lo) + or else Raises_Constraint_Error (Hi) + then + Raises_CE := True; + return; + + -- AI05-0188 : Within an instance the non-others choices do not + -- have to belong to the actual subtype. + + elsif Ada_Version >= Ada_2012 and then In_Instance then + return; + + -- Otherwise we have an OK static choice + + else + Lo_Val := Expr_Value (Lo); + Hi_Val := Expr_Value (Hi); + + -- Do not insert null ranges in the choices table + + if Lo_Val > Hi_Val then + Process_Empty_Choice (Choice); + return; + end if; + end if; + + -- Check for low bound out of range + + if Lo_Val < Bounds_Lo then + + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise post it on the lower bound of the range. + + if Is_Entity_Name (Choice) then + Enode := Choice; + else + Enode := Lo; + end if; + + -- Specialize message for integer/enum type + + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Bounds_Lo; + Error_Msg_N ("minimum allowed choice value is^", Enode); + else + Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); + Error_Msg_N ("minimum allowed choice value is%", Enode); + end if; + end if; + + -- Check for high bound out of range + + if Hi_Val > Bounds_Hi then + + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise post it on the upper bound of the range. + + if Is_Entity_Name (Choice) then + Enode := Choice; + else + Enode := Hi; + end if; + + -- Specialize message for integer/enum type + + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Bounds_Hi; + Error_Msg_N ("maximum allowed choice value is^", Enode); + else + Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); + Error_Msg_N ("maximum allowed choice value is%", Enode); + end if; + end if; + + -- Collect bounds in the list + + -- Note: we still store the bounds, even if they are out of range, + -- since this may prevent unnecessary cascaded errors for values + -- that are covered by such an excessive range. + + Choice_List := + new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); + Num_Choices := Num_Choices + 1; + end Check; + + -- Start of processing for Check_Choices + + begin + Raises_CE := False; + Others_Present := False; + + -- If Subtyp is not a discrete type or there was some other error, + -- then don't try any semantic checking on the choices since we have + -- a complete mess. + + if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then + return; + end if; + + -- If Subtyp is not a static subtype Ada 95 requires then we use the + -- bounds of its base type to determine the values covered by the + -- discrete choices. + + -- In Ada 2012, if the subtype has a non-static predicate the full + -- range of the base type must be covered as well. + + if Is_OK_Static_Subtype (Subtyp) then + if not Has_Predicates (Subtyp) + or else Present (Static_Predicate (Subtyp)) + then + Bounds_Type := Subtyp; + else + Bounds_Type := Choice_Type; + end if; + + else + Bounds_Type := Choice_Type; + end if; + + -- Obtain static bounds of type, unless this is a generic formal + -- discrete type for which all choices will be non-static. + + if not Is_Generic_Type (Root_Type (Bounds_Type)) + or else Ekind (Bounds_Type) /= E_Enumeration_Type + then + Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); + Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); + end if; + + if Choice_Type = Universal_Integer then + Expected_Type := Any_Integer; + else + Expected_Type := Choice_Type; + end if; + + -- Now loop through the case alternatives or record variants + + Alt := First (Alternatives); + while Present (Alt) loop + + -- If pragma, just analyze it + + if Nkind (Alt) = N_Pragma then + Analyze (Alt); + + -- Otherwise we have an alternative. In most cases the semantic + -- processing leaves the list of choices unchanged + + -- Check each choice against its base type + + else + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop + Kind := Nkind (Choice); + + -- Choice is a Range + + if Kind = N_Range + or else (Kind = N_Attribute_Reference + and then Attribute_Name (Choice) = Name_Range) + then + Check (Choice, Low_Bound (Choice), High_Bound (Choice)); + + -- Choice is a subtype name + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + -- Check for inappropriate type + + if not Covers (Expected_Type, Etype (Choice)) then + Wrong_Type (Choice, Choice_Type); + + -- Type is OK, so check further + + else + E := Entity (Choice); + + -- Case of predicated subtype + + if Has_Predicates (E) then + + -- Use of non-static predicate is an error + + if not Is_Discrete_Type (E) + or else No (Static_Predicate (E)) + then + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static " + & "predicate as case alternative", + Choice, E, Suggest_Static => True); + + -- Static predicate case + + else + declare + P : Node_Id; + C : Node_Id; + + begin + -- Loop through entries in predicate list, + -- checking each entry. Note that if the + -- list is empty, corresponding to a False + -- predicate, then no choices are checked. + + P := First (Static_Predicate (E)); + while Present (P) loop + C := New_Copy (P); + Set_Sloc (C, Sloc (Choice)); + Check (C, Low_Bound (C), High_Bound (C)); + Next (P); + end loop; + end; + + Set_Has_SP_Choice (Alt); + end if; + + -- Not predicated subtype case + + elsif not Is_Static_Subtype (E) then + Process_Non_Static_Choice (Choice); + else + Check + (Choice, Type_Low_Bound (E), Type_High_Bound (E)); + end if; + end if; + + -- Choice is a subtype indication + + elsif Kind = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication + (Choice, Expected_Type); + + if Etype (Choice) /= Any_Type then + declare + C : constant Node_Id := Constraint (Choice); + R : constant Node_Id := Range_Expression (C); + L : constant Node_Id := Low_Bound (R); + H : constant Node_Id := High_Bound (R); + + begin + E := Entity (Subtype_Mark (Choice)); + + if not Is_Static_Subtype (E) then + Process_Non_Static_Choice (Choice); + + else + if Is_OK_Static_Expression (L) + and then + Is_OK_Static_Expression (H) + then + if Expr_Value (L) > Expr_Value (H) then + Process_Empty_Choice (Choice); + else + if Is_Out_Of_Range (L, E) then + Apply_Compile_Time_Constraint_Error + (L, "static value out of range", + CE_Range_Check_Failed); + end if; + + if Is_Out_Of_Range (H, E) then + Apply_Compile_Time_Constraint_Error + (H, "static value out of range", + CE_Range_Check_Failed); + end if; + end if; + end if; + + Check (Choice, L, H); + end if; + end; + end if; + + -- The others choice is only allowed for the last + -- alternative and as its only choice. + + elsif Kind = N_Others_Choice then + if not (Choice = First (Discrete_Choices (Alt)) + and then Choice = Last (Discrete_Choices (Alt)) + and then Alt = Last (Alternatives)) + then + Error_Msg_N + ("the choice OTHERS must appear alone and last", + Choice); + return; + end if; + + Others_Present := True; + Others_Choice := Choice; + + -- Only other possibility is an expression + + else + Check (Choice, Choice, Choice); + end if; + + -- Move to next choice + + Next (Choice); + end loop; + + Process_Associated_Node (Alt); + end if; + + Next (Alt); + end loop; + + -- Now we can create the Choice_Table, since we know how long + -- it needs to be so we can allocate exactly the right length. + + declare + Choice_Table : Choice_Table_Type (0 .. Num_Choices); + + begin + -- Now copy the items we collected in the linked list into this + -- newly allocated table (leave entry 0 unused for sorting). + + declare + T : Link_Ptr; + begin + for J in 1 .. Num_Choices loop + T := Choice_List; + Choice_List := T.Nxt; + Choice_Table (J) := T.Val; + Free (T); + end loop; + end; + + Check_Choice_Set + (Choice_Table, + Bounds_Type, + Subtyp, + Others_Present or else (Choice_Type = Universal_Integer), + N); + + -- If no others choice we are all done, otherwise we have one more + -- step, which is to set the Others_Discrete_Choices field of the + -- others choice (to contain all otherwise unspecified choices). + -- Skip this if CE is known to be raised. + + if Others_Present and not Raises_CE then + Expand_Others_Choice + (Case_Table => Choice_Table, + Others_Choice => Others_Choice, + Choice_Type => Bounds_Type); + end if; + end; + end Check_Choices; + + end Generic_Check_Choices; + +end Sem_Case; |