------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C A S E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1996-2014, 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 Predicate_Error : Boolean; -- Flag to prevent cascaded errors when a static predicate is known to -- be violated by one choice. 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 -- but there is a gap after Prev_Hi. else Missing_Choice (Prev_Hi + 1, 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 duplicated if Lo = Hi then -- Integer type if Is_Integer_Type (Bounds_Type) then -- We have an integer value, Lo, but if the given choice -- placement is a constant with that value, then use the -- name of that constant instead in the message: if Nkind (C) = N_Identifier and then Compile_Time_Known_Value (C) and then Expr_Value (C) = Lo then Error_Msg_N ("duplication of choice value: &#!", C); -- Not that special case, so just output the integer value else Error_Msg_Uint_1 := Lo; Error_Msg_N ("duplication of choice value: ^#!", C); end if; -- Enumeration type 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 -- Integer type if Is_Integer_Type (Bounds_Type) then -- Similar to the above, if C is a range of known values which -- match Lo and Hi, then use the names. We have to go to the -- original nodes, since the values will have been rewritten -- to their integer values. if Nkind (C) = N_Range and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier and then Nkind (Original_Node (High_Bound (C))) = N_Identifier and then Compile_Time_Known_Value (Low_Bound (C)) and then Compile_Time_Known_Value (High_Bound (C)) and then Expr_Value (Low_Bound (C)) = Lo and then Expr_Value (High_Bound (C)) = Hi then Error_Msg_Node_2 := Original_Node (High_Bound (C)); Error_Msg_N ("duplication of choice values: & .. &#!", Original_Node (Low_Bound (C))); -- Not that special case, output integer values else Error_Msg_Uint_1 := Lo; Error_Msg_Uint_2 := Hi; Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); end if; -- Enumeration type 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; -------------------- -- 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; -- If predicate is already known to be violated, do no check for -- coverage error, to prevent cascaded messages. elsif Predicate_Error 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); Num_Choices : constant Nat := Choice_Table'Last; Has_Predicate : constant Boolean := Is_OK_Static_Subtype (Bounds_Type) and then Has_Static_Predicate (Bounds_Type); 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 -- If the case is part of a predicate aspect specification, do not -- recheck it against itself. if Present (Parent (Case_Node)) and then Nkind (Parent (Case_Node)) = N_Aspect_Specification then return; end if; Predicate_Error := False; -- 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. -- Note that in GNAT the predicate is considered static if the predicate -- expression is static, independently of whether the aspect mentions -- Static explicitly. if Has_Predicate then Pred := First (Static_Discrete_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. Do not examine other choices unless -- all errors are requested. if Error then Predicate_Error := True; if not All_Errors_Mode then return; end if; end if; end loop; if Predicate_Error then return; end if; -- 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_OK_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_OK_Static_Expression (Lo) or else not Is_OK_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 Has_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 not Has_Static_Predicate (E) or else Has_Dynamic_Predicate_Aspect (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_Discrete_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_OK_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_OK_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;