-- --
-- B o d y --
-- --
--- $Revision: 1.13 $
--- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2006, 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- --
-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
+with Tbuild; use Tbuild;
with Uintp; use Uintp;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
Bounds_Type : Entity_Id;
Others_Present : Boolean;
Msg_Sloc : Source_Ptr);
- -- This is the procedure which verifies that a set of case statement,
- -- array aggregate 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.
+ -- 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
-- 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 Analyze_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_Choices --
-------------------
Others_Present : Boolean;
Msg_Sloc : Source_Ptr)
is
-
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.
+ -- Comparison routine for comparing Choice_Table entries. Use the lower
+ -- bound of each Choice as the key.
procedure Move_Choice (From : Natural; To : Natural);
- -- Move routine for sorting the Choice_Table.
+ -- Move routine for sorting the Choice_Table
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
begin
return
Expr_Value (Choice_Table (Nat (C1)).Lo)
- <= Expr_Value (Choice_Table (Nat (C2)).Lo);
+ <
+ Expr_Value (Choice_Table (Nat (C2)).Lo);
end Lt_Choice;
-----------------
-- Start processing for Check_Choices
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.
C : Int;
begin
- -- For character, or wide character. If we are in 7-bit ASCII graphic
+ -- For character, or wide [wide] character. If 7-bit ASCII graphic
-- range, then build and return appropriate character literal name
if Rtp = Standard_Character
or else Rtp = Standard_Wide_Character
+ or else Rtp = Standard_Wide_Wide_Character
then
C := UI_To_Int (Value);
if C in 16#20# .. 16#7E# then
- Name_Buffer (1) := ''';
- Name_Buffer (2) := Character'Val (C);
- Name_Buffer (3) := ''';
- Name_Len := 3;
+ Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
return Name_Find;
end if;
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 the
+ -- 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 Root_Type (Choice_Type) = Standard_Character
+ or else
+ Root_Type (Choice_Type) = Standard_Wide_Character
+ or else
+ Root_Type (Choice_Type) = Standard_Wide_Wide_Character
+ 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'Length = 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 (Case_Table'First).Lo);
+ Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+ Previous_Hi := Expr_Value (Case_Table (Case_Table'First).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 Case_Table'First + 1 .. 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 ("?OTHERS choice is redundant", Others_Choice);
+ Error_Msg_N ("\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;
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
- Choice_Table : in out Choice_Table_Type;
+ Choice_Table : out Choice_Table_Type;
Last_Choice : out Nat;
Raises_CE : out Boolean;
Others_Present : out Boolean)
is
+ pragma Assert (Choice_Table'First = 1);
+
+ E : Entity_Id;
+
+ Enode : Node_Id;
+ -- This is where we post error messages for bounds out of range
Nb_Choices : constant Nat := Choice_Table'Length;
Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
Bounds_Type : Entity_Id;
-- The type from which are derived the bounds of the values
- -- covered by th discrete choices (see 3.8.1 (4)). If a discrete
+ -- 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.
+ 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 entered into
end if;
end if;
- -- Check for bound out of range.
+ -- 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 we want to 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^", 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%", Lo);
+ 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 we want to post it on the upper bound
+ -- of the range.
+
+ if Is_Entity_Name (Choice) then
+ Enode := Choice;
+ else
+ Enode := Hi;
end if;
- elsif Hi_Val > Bounds_Hi then
+ -- 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^", 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%", Hi);
+ Error_Msg_N ("maximum allowed choice value is%", Enode);
end if;
end if;
- -- We still store the bounds in the table, even if they are out
- -- of range, since this may prevent unnecessary cascaded errors
+ -- Store bounds in the table
+
+ -- 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.
Last_Choice := Last_Choice + 1;
Sort_Choice_Table (Last_Choice).Node := Choice;
end Check;
- -- Variables local to Analyze_Choices
-
- Alt : Node_Id;
- -- A case statement alternative, an array aggregate component
- -- association or a variant in a record type declaration
-
- Choice : Node_Id;
- Kind : Node_Kind;
- -- The node kind of the current Choice.
-
- E : Entity_Id;
-
-- Start of processing for Analyze_Choices
begin
Expected_Type := Choice_Type;
end if;
- -- Now loop through the case statement alternatives or array
- -- aggregate component associations or record variants.
+ -- Now loop through the case alternatives or record variants
Alt := First (Get_Alternatives (N));
while Present (Alt) loop
if Kind = N_Range
or else (Kind = N_Attribute_Reference
- and then Attribute_Name (Choice) = Name_Range)
+ and then Attribute_Name (Choice) = Name_Range)
then
Resolve (Choice, Expected_Type);
Check (Choice, Low_Bound (Choice), High_Bound (Choice));
else
if Is_Out_Of_Range (L, E) then
Apply_Compile_Time_Constraint_Error
- (L, "static value out of range");
+ (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");
+ (H, "static value out of range",
+ CE_Range_Check_Failed);
end if;
end if;
end if;
end if;
Others_Present := True;
+ Others_Choice := Choice;
-- Only other possibility is an expression
Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
end loop;
+ -- 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 (1 .. Last_Choice),
+ Others_Choice => Others_Choice,
+ Choice_Type => Bounds_Type);
+ end if;
end Analyze_Choices;
-----------------------
function Number_Of_Choices (N : Node_Id) return Nat is
Alt : Node_Id;
- -- A case statement alternative, an array aggregate component
- -- association or a record variant.
+ -- A case statement alternative or a record variant
Choice : Node_Id;
Count : Nat := 0;
begin
- if not Present (Get_Alternatives (N)) then
+ if No (Get_Alternatives (N)) then
return 0;
end if;
OSDN Git Service
