1797 lines
61 KiB
Ada
1797 lines
61 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S E M _ C A S E --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1996-2016, 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 := False;
|
|
-- Flag to prevent cascaded errors when a static predicate is known to
|
|
-- be violated by one choice.
|
|
|
|
Num_Choices : constant Nat := Choice_Table'Last;
|
|
|
|
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 Check_Duplicates;
|
|
-- Check for duplicate choices, and call Dup_Choice if there are any
|
|
-- such errors. Note that predicates are irrelevant here.
|
|
|
|
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 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: Ignore duplicate choices, other than to set the flag,
|
|
-- because these were already detected by Check_Duplicates.
|
|
|
|
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
|
|
or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
|
|
then
|
|
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;
|
|
|
|
----------------------
|
|
-- Check_Duplicates --
|
|
----------------------
|
|
|
|
procedure Check_Duplicates is
|
|
Choice : Node_Id;
|
|
Choice_Hi : Uint;
|
|
Choice_Lo : Uint;
|
|
Prev_Choice : Node_Id;
|
|
Prev_Hi : Uint;
|
|
|
|
begin
|
|
Prev_Hi := Expr_Value (Choice_Table (1).Hi);
|
|
|
|
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);
|
|
|
|
-- Choices overlap; this is an error
|
|
|
|
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;
|
|
end if;
|
|
|
|
if Choice_Hi > Prev_Hi then
|
|
Prev_Hi := Choice_Hi;
|
|
end if;
|
|
end loop;
|
|
end Check_Duplicates;
|
|
|
|
----------------
|
|
-- 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. Examine
|
|
-- whether original node is an entity, because it may have been
|
|
-- constant-folded to a literal if value is known.
|
|
|
|
elsif not Is_Entity_Name (Original_Node (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);
|
|
Has_Predicate : constant Boolean :=
|
|
Is_OK_Static_Subtype (Bounds_Type)
|
|
and then Has_Static_Predicate (Bounds_Type);
|
|
|
|
Choice_Hi : Uint;
|
|
Choice_Lo : Uint;
|
|
Pred : 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;
|
|
|
|
-- 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));
|
|
|
|
-- First check for duplicates. This involved the choices; predicates, if
|
|
-- any, are irrelevant.
|
|
|
|
Check_Duplicates;
|
|
|
|
-- Then check for overlaps
|
|
|
|
-- If the subtype has 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));
|
|
|
|
-- Make initial value smaller than 'First of type, so that first
|
|
-- range comparison succeeds. This applies both to integer types
|
|
-- and to enumeration types.
|
|
|
|
Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
|
|
Prev_Hi := Prev_Lo;
|
|
|
|
declare
|
|
Error : Boolean := False;
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
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 Index in 2 .. Num_Choices loop
|
|
Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
|
|
Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
|
|
|
|
if Choice_Lo > Prev_Hi + 1 and then not Others_Present 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
|
|
begin
|
|
if Nkind (C) = N_Range and then Warn_On_Redundant_Constructs then
|
|
Error_Msg_N ("choice is an empty range?r?", C);
|
|
end if;
|
|
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.
|
|
|
|
procedure Handle_Static_Predicate
|
|
(Typ : Entity_Id;
|
|
Lo : Node_Id;
|
|
Hi : Node_Id);
|
|
-- If the type of the alternative has predicates, we must examine
|
|
-- each subset of the predicate rather than the bounds of the type
|
|
-- itself. This is relevant when the choice is a subtype mark or a
|
|
-- subtype indication.
|
|
|
|
-----------
|
|
-- 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;
|
|
|
|
-----------------------------
|
|
-- Handle_Static_Predicate --
|
|
-----------------------------
|
|
|
|
procedure Handle_Static_Predicate
|
|
(Typ : Entity_Id;
|
|
Lo : Node_Id;
|
|
Hi : Node_Id)
|
|
is
|
|
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. If the choice comes
|
|
-- from a subtype indication, the given range may have bounds
|
|
-- that narrow the predicate choices themselves, so we must
|
|
-- consider only those entries within the range of the given
|
|
-- subtype indication..
|
|
|
|
P := First (Static_Discrete_Predicate (Typ));
|
|
while Present (P) loop
|
|
|
|
-- Check that part of the predicate choice is included in the
|
|
-- given bounds.
|
|
|
|
if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
|
|
and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
|
|
then
|
|
C := New_Copy (P);
|
|
Set_Sloc (C, Sloc (Choice));
|
|
|
|
if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
|
|
Set_Low_Bound (C, Lo);
|
|
end if;
|
|
|
|
if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
|
|
Set_High_Bound (C, Hi);
|
|
end if;
|
|
|
|
Check (C, Low_Bound (C), High_Bound (C));
|
|
end if;
|
|
|
|
Next (P);
|
|
end loop;
|
|
|
|
Set_Has_SP_Choice (Alt);
|
|
end Handle_Static_Predicate;
|
|
|
|
-- 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. The bounds are those of
|
|
-- the given subtype.
|
|
|
|
else
|
|
Handle_Static_Predicate (E,
|
|
Type_Low_Bound (E), Type_High_Bound (E));
|
|
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 applicable predicate values within the
|
|
-- bounds of the given range.
|
|
|
|
if Has_Static_Predicate (E) then
|
|
Handle_Static_Predicate (E, L, H);
|
|
|
|
else
|
|
Check (Choice, L, H);
|
|
end if;
|
|
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;
|