mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-13 08:29:53 +00:00
3874 lines
148 KiB
Ada
3874 lines
148 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S E M _ C A S E --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1996-2022, 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 Einfo.Entities; use Einfo.Entities;
|
|
with Einfo.Utils; use Einfo.Utils;
|
|
with Elists; use Elists;
|
|
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 Sinfo.Nodes; use Sinfo.Nodes;
|
|
with Sinfo.Utils; use Sinfo.Utils;
|
|
with Stringt; use Stringt;
|
|
with Table;
|
|
with Tbuild; use Tbuild;
|
|
with Uintp; use Uintp;
|
|
|
|
with Ada.Unchecked_Deallocation;
|
|
|
|
with GNAT.Heap_Sort_G;
|
|
with GNAT.Sets;
|
|
|
|
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 nonstatic
|
|
-- 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.
|
|
|
|
function Has_Static_Discriminant_Constraint
|
|
(Subtyp : Entity_Id) return Boolean;
|
|
-- Returns True if the given subtype is subject to a discriminant
|
|
-- constraint and at least one of the constraint values is nonstatic.
|
|
|
|
package Composite_Case_Ops is
|
|
|
|
function Box_Value_Required (Subtyp : Entity_Id) return Boolean;
|
|
-- If result is True, then the only allowed value (in a choice
|
|
-- aggregate) for a component of this (sub)type is a box. This rule
|
|
-- means that such a component can be ignored in case alternative
|
|
-- selection. This in turn implies that it is ok if the component
|
|
-- type doesn't meet the usual restrictions, such as not being an
|
|
-- access/task/protected type, since nobody is going to look
|
|
-- at it.
|
|
|
|
function Choice_Count (Alternatives : List_Id) return Nat;
|
|
-- The sum of the number of choices for each alternative in the given
|
|
-- list.
|
|
|
|
function Normalized_Case_Expr_Type
|
|
(Case_Statement : Node_Id) return Entity_Id;
|
|
-- Usually returns the Etype of the selector expression of the
|
|
-- case statement. However, in the case of a constrained composite
|
|
-- subtype with a nonstatic constraint, returns the unconstrained
|
|
-- base type.
|
|
|
|
function Scalar_Part_Count (Subtyp : Entity_Id) return Nat;
|
|
-- Given the composite type Subtyp of a case selector, returns the
|
|
-- number of scalar parts in an object of this type. This is the
|
|
-- dimensionality of the associated Cartesian product space.
|
|
|
|
package Array_Case_Ops is
|
|
function Array_Choice_Length (Choice : Node_Id) return Nat;
|
|
-- Given a choice expression of an array type, returns its length.
|
|
|
|
function Unconstrained_Array_Effective_Length
|
|
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat;
|
|
-- If the nominal subtype of the case selector is unconstrained,
|
|
-- then use the length of the longest choice of the case statement.
|
|
-- Components beyond that index value will not influence the case
|
|
-- selection decision.
|
|
|
|
function Unconstrained_Array_Scalar_Part_Count
|
|
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat;
|
|
-- Same as Scalar_Part_Count except that the value used for the
|
|
-- "length" of the array subtype being cased on is determined by
|
|
-- calling Unconstrained_Array_Effective_Length.
|
|
end Array_Case_Ops;
|
|
|
|
generic
|
|
Case_Statement : Node_Id;
|
|
package Choice_Analysis is
|
|
|
|
use Array_Case_Ops;
|
|
|
|
type Alternative_Id is
|
|
new Int range 1 .. List_Length (Alternatives (Case_Statement));
|
|
type Choice_Id is
|
|
new Int range 1 .. Choice_Count (Alternatives (Case_Statement));
|
|
|
|
Case_Expr_Type : constant Entity_Id :=
|
|
Normalized_Case_Expr_Type (Case_Statement);
|
|
|
|
Unconstrained_Array_Case : constant Boolean :=
|
|
Is_Array_Type (Case_Expr_Type)
|
|
and then not Is_Constrained (Case_Expr_Type);
|
|
|
|
-- If Unconstrained_Array_Case is True, choice lengths may differ:
|
|
-- when "Aaa" | "Bb" | "C" | "" =>
|
|
--
|
|
-- Strictly speaking, the name "Unconstrained_Array_Case" is
|
|
-- slightly imprecise; a subtype with a nonstatic constraint is
|
|
-- also treated as unconstrained (see Normalize_Case_Expr_Type).
|
|
|
|
type Part_Id is new Int range
|
|
1 .. (if Unconstrained_Array_Case
|
|
then Unconstrained_Array_Scalar_Part_Count
|
|
(Case_Expr_Type, Case_Statement)
|
|
else Scalar_Part_Count (Case_Expr_Type));
|
|
|
|
type Discrete_Range_Info is
|
|
record
|
|
Low, High : Uint;
|
|
end record;
|
|
|
|
type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info;
|
|
|
|
type Choice_Range_Info (Is_Others : Boolean := False) is
|
|
record
|
|
case Is_Others is
|
|
when False =>
|
|
Ranges : Composite_Range_Info;
|
|
when True =>
|
|
null;
|
|
end case;
|
|
end record;
|
|
|
|
type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info;
|
|
|
|
package Value_Sets is
|
|
|
|
type Value_Set is private;
|
|
-- A set of points in the Cartesian product space defined
|
|
-- by the composite type of the case selector.
|
|
-- Implemented as an access type.
|
|
|
|
type Set_Comparison is
|
|
(Disjoint, Equal, Contains, Contained_By, Overlaps);
|
|
|
|
function Compare (S1, S2 : Value_Set) return Set_Comparison;
|
|
-- If either argument (or both) is empty, result is Disjoint.
|
|
-- Otherwise, result is Equal if the two sets are equal.
|
|
|
|
Empty : constant Value_Set;
|
|
|
|
function Matching_Values
|
|
(Info : Composite_Range_Info) return Value_Set;
|
|
-- The Cartesian product of the given array of ranges
|
|
-- (excluding any values outside the Cartesian product of the
|
|
-- component ranges).
|
|
|
|
procedure Union (Target : in out Value_Set; Source : Value_Set);
|
|
-- Add elements of Source into Target
|
|
|
|
procedure Remove (Target : in out Value_Set; Source : Value_Set);
|
|
-- Remove elements of Source from Target
|
|
|
|
function Complement_Is_Empty (Set : Value_Set) return Boolean;
|
|
-- Return True iff the set is "maximal", in the sense that it
|
|
-- includes every value in the Cartesian product of the
|
|
-- component ranges.
|
|
|
|
procedure Free_Value_Sets;
|
|
-- Reclaim storage associated with implementation of this package.
|
|
|
|
private
|
|
type Value_Set is new Natural;
|
|
-- An index for a table that will be declared in the package body.
|
|
|
|
Empty : constant Value_Set := 0;
|
|
|
|
end Value_Sets;
|
|
|
|
type Single_Choice_Info (Is_Others : Boolean := False) is
|
|
record
|
|
Alternative : Alternative_Id;
|
|
case Is_Others is
|
|
when False =>
|
|
Matches : Value_Sets.Value_Set;
|
|
when True =>
|
|
null;
|
|
end case;
|
|
end record;
|
|
|
|
type Choices_Info is array (Choice_Id) of Single_Choice_Info;
|
|
|
|
function Analysis return Choices_Info;
|
|
-- Parse the case choices in order to determine the set of
|
|
-- matching values associated with each choice.
|
|
|
|
type Bound_Values is array (Positive range <>) of Node_Id;
|
|
|
|
end Choice_Analysis;
|
|
|
|
end Composite_Case_Ops;
|
|
|
|
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 nonstatic bound, requiring the base type to
|
|
-- be covered. Provides where possible a helpful explanation of why the
|
|
-- bounds are nonstatic, 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 := Empty;
|
|
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;
|
|
|
|
pragma Assert (Present (Prev_Choice));
|
|
|
|
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: &#!", Original_Node (C));
|
|
|
|
-- Not that special case, so just output the integer value
|
|
|
|
else
|
|
Error_Msg_Uint_1 := Lo;
|
|
Error_Msg_N
|
|
("duplication of choice value: ^#!", Original_Node (C));
|
|
end if;
|
|
|
|
-- Enumeration type
|
|
|
|
else
|
|
Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type);
|
|
Error_Msg_N
|
|
("duplication of choice value: %#!", Original_Node (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: ^ .. ^#!",
|
|
Original_Node (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: % .. %#!", Original_Node (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 nonstatic
|
|
-- 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
|
|
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 not 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_N ("missing case value: ^!", Case_Node);
|
|
else
|
|
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
|
|
Error_Msg_N ("missing case value: %!", Case_Node);
|
|
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_N ("missing case values: ^ .. ^!", Case_Node);
|
|
else
|
|
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
|
|
Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
|
|
Error_Msg_N ("missing case values: % .. %!", Case_Node);
|
|
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;
|
|
|
|
package body Composite_Case_Ops is
|
|
|
|
function Static_Array_Length (Subtyp : Entity_Id) return Nat;
|
|
-- Given a one-dimensional constrained array subtype with
|
|
-- statically known bounds, return its length.
|
|
|
|
-------------------------
|
|
-- Static_Array_Length --
|
|
-------------------------
|
|
|
|
function Static_Array_Length (Subtyp : Entity_Id) return Nat is
|
|
pragma Assert (Is_Constrained (Subtyp));
|
|
pragma Assert (Number_Dimensions (Subtyp) = 1);
|
|
Index : constant Node_Id := First_Index (Subtyp);
|
|
pragma Assert (Is_OK_Static_Range (Index));
|
|
Lo : constant Uint := Expr_Value (Low_Bound (Index));
|
|
Hi : constant Uint := Expr_Value (High_Bound (Index));
|
|
Len : constant Uint := UI_Max (0, (Hi - Lo) + 1);
|
|
begin
|
|
return UI_To_Int (Len);
|
|
end Static_Array_Length;
|
|
|
|
------------------------
|
|
-- Box_Value_Required --
|
|
------------------------
|
|
|
|
function Box_Value_Required (Subtyp : Entity_Id) return Boolean is
|
|
-- Some of these restrictions will be relaxed eventually, but best
|
|
-- to initially err in the direction of being too restrictive.
|
|
begin
|
|
if Has_Predicates (Subtyp) then
|
|
return True;
|
|
elsif Is_Discrete_Type (Subtyp) then
|
|
if not Is_Static_Subtype (Subtyp) then
|
|
return True;
|
|
elsif Is_Enumeration_Type (Subtyp)
|
|
and then Has_Enumeration_Rep_Clause (Subtyp)
|
|
-- Maybe enumeration rep clauses can be ignored here?
|
|
then
|
|
return True;
|
|
end if;
|
|
elsif Is_Array_Type (Subtyp) then
|
|
if Number_Dimensions (Subtyp) /= 1 then
|
|
return True;
|
|
elsif not Is_Constrained (Subtyp) then
|
|
if not Is_Static_Subtype (Etype (First_Index (Subtyp))) then
|
|
return True;
|
|
end if;
|
|
elsif not Is_OK_Static_Range (First_Index (Subtyp)) then
|
|
return True;
|
|
end if;
|
|
elsif Is_Record_Type (Subtyp) then
|
|
if Has_Discriminants (Subtyp)
|
|
and then Is_Constrained (Subtyp)
|
|
and then not Has_Static_Discriminant_Constraint (Subtyp)
|
|
then
|
|
-- Perhaps treat differently the case where Subtyp is the
|
|
-- subtype of the top-level selector expression, as opposed
|
|
-- to the subtype of some subcomponent thereof.
|
|
return True;
|
|
end if;
|
|
else
|
|
-- Return True for any type that is not a discrete type,
|
|
-- a record type, or an array type.
|
|
return True;
|
|
end if;
|
|
|
|
return False;
|
|
end Box_Value_Required;
|
|
|
|
------------------
|
|
-- Choice_Count --
|
|
------------------
|
|
|
|
function Choice_Count (Alternatives : List_Id) return Nat is
|
|
Result : Nat := 0;
|
|
Alt : Node_Id := First (Alternatives);
|
|
begin
|
|
while Present (Alt) loop
|
|
Result := Result + List_Length (Discrete_Choices (Alt));
|
|
Next (Alt);
|
|
end loop;
|
|
return Result;
|
|
end Choice_Count;
|
|
|
|
-------------------------------
|
|
-- Normalized_Case_Expr_Type --
|
|
-------------------------------
|
|
|
|
function Normalized_Case_Expr_Type
|
|
(Case_Statement : Node_Id) return Entity_Id
|
|
is
|
|
Unnormalized : constant Entity_Id :=
|
|
Etype (Expression (Case_Statement));
|
|
|
|
Is_Dynamically_Constrained_Array : constant Boolean :=
|
|
Is_Array_Type (Unnormalized)
|
|
and then Is_Constrained (Unnormalized)
|
|
and then not Has_Static_Array_Bounds (Unnormalized);
|
|
|
|
Is_Dynamically_Constrained_Record : constant Boolean :=
|
|
Is_Record_Type (Unnormalized)
|
|
and then Has_Discriminants (Unnormalized)
|
|
and then Is_Constrained (Unnormalized)
|
|
and then not Has_Static_Discriminant_Constraint (Unnormalized);
|
|
begin
|
|
if Is_Dynamically_Constrained_Array
|
|
or Is_Dynamically_Constrained_Record
|
|
then
|
|
return Base_Type (Unnormalized);
|
|
else
|
|
return Unnormalized;
|
|
end if;
|
|
end Normalized_Case_Expr_Type;
|
|
|
|
-----------------------
|
|
-- Scalar_Part_Count --
|
|
-----------------------
|
|
|
|
function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is
|
|
begin
|
|
if Box_Value_Required (Subtyp) then
|
|
return 0; -- component does not participate in case selection
|
|
elsif Is_Scalar_Type (Subtyp) then
|
|
return 1;
|
|
elsif Is_Array_Type (Subtyp) then
|
|
return Static_Array_Length (Subtyp)
|
|
* Scalar_Part_Count (Component_Type (Subtyp));
|
|
elsif Is_Record_Type (Subtyp) then
|
|
declare
|
|
Result : Nat := 0;
|
|
Comp : Entity_Id := First_Component_Or_Discriminant
|
|
(Base_Type (Subtyp));
|
|
begin
|
|
while Present (Comp) loop
|
|
Result := Result + Scalar_Part_Count (Etype (Comp));
|
|
Next_Component_Or_Discriminant (Comp);
|
|
end loop;
|
|
return Result;
|
|
end;
|
|
else
|
|
pragma Assert (Serious_Errors_Detected > 0);
|
|
return 0;
|
|
end if;
|
|
end Scalar_Part_Count;
|
|
|
|
package body Array_Case_Ops is
|
|
|
|
-------------------------
|
|
-- Array_Choice_Length --
|
|
-------------------------
|
|
|
|
function Array_Choice_Length (Choice : Node_Id) return Nat is
|
|
begin
|
|
case Nkind (Choice) is
|
|
when N_String_Literal =>
|
|
return String_Length (Strval (Choice));
|
|
when N_Aggregate =>
|
|
declare
|
|
Bounds : constant Node_Id :=
|
|
Aggregate_Bounds (Choice);
|
|
pragma Assert (Is_OK_Static_Range (Bounds));
|
|
Lo : constant Uint :=
|
|
Expr_Value (Low_Bound (Bounds));
|
|
Hi : constant Uint :=
|
|
Expr_Value (High_Bound (Bounds));
|
|
Len : constant Uint := (Hi - Lo) + 1;
|
|
begin
|
|
return UI_To_Int (Len);
|
|
end;
|
|
when N_Has_Entity =>
|
|
if Present (Entity (Choice))
|
|
and then Ekind (Entity (Choice)) = E_Constant
|
|
then
|
|
return Array_Choice_Length
|
|
(Expression (Parent (Entity (Choice))));
|
|
end if;
|
|
when N_Others_Choice =>
|
|
return 0;
|
|
when others =>
|
|
null;
|
|
end case;
|
|
|
|
if Nkind (Original_Node (Choice))
|
|
in N_String_Literal | N_Aggregate
|
|
then
|
|
return Array_Choice_Length (Original_Node (Choice));
|
|
end if;
|
|
|
|
Error_Msg_N ("Unsupported case choice", Choice);
|
|
return 0;
|
|
end Array_Choice_Length;
|
|
|
|
------------------------------------------
|
|
-- Unconstrained_Array_Effective_Length --
|
|
------------------------------------------
|
|
|
|
function Unconstrained_Array_Effective_Length
|
|
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat
|
|
is
|
|
pragma Assert (Is_Array_Type (Array_Type));
|
|
-- Array_Type is otherwise unreferenced for now.
|
|
|
|
Result : Nat := 0;
|
|
Alt : Node_Id := First (Alternatives (Case_Statement));
|
|
begin
|
|
while Present (Alt) loop
|
|
declare
|
|
Choice : Node_Id := First (Discrete_Choices (Alt));
|
|
begin
|
|
while Present (Choice) loop
|
|
Result := Nat'Max (Result, Array_Choice_Length (Choice));
|
|
Next (Choice);
|
|
end loop;
|
|
end;
|
|
Next (Alt);
|
|
end loop;
|
|
|
|
return Result;
|
|
end Unconstrained_Array_Effective_Length;
|
|
|
|
-------------------------------------------
|
|
-- Unconstrained_Array_Scalar_Part_Count --
|
|
-------------------------------------------
|
|
|
|
function Unconstrained_Array_Scalar_Part_Count
|
|
(Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat
|
|
is
|
|
begin
|
|
-- Add one for the length, which is treated like a discriminant
|
|
|
|
return 1 + (Unconstrained_Array_Effective_Length
|
|
(Array_Type => Array_Type,
|
|
Case_Statement => Case_Statement)
|
|
* Scalar_Part_Count (Component_Type (Array_Type)));
|
|
end Unconstrained_Array_Scalar_Part_Count;
|
|
|
|
end Array_Case_Ops;
|
|
|
|
package body Choice_Analysis is
|
|
|
|
function Component_Bounds_Info return Composite_Range_Info;
|
|
-- Returns the (statically known) bounds for each component.
|
|
-- The selector expression value (or any other value of the type
|
|
-- of the selector expression) can be thought of as a point in the
|
|
-- Cartesian product of these sets.
|
|
|
|
function Parse_Choice (Choice : Node_Id;
|
|
Alt : Node_Id) return Choice_Range_Info;
|
|
-- Extract Choice_Range_Info from a Choice node
|
|
|
|
---------------------------
|
|
-- Component_Bounds_Info --
|
|
---------------------------
|
|
|
|
function Component_Bounds_Info return Composite_Range_Info is
|
|
Result : Composite_Range_Info;
|
|
Next : Part_Id := 1;
|
|
Done : Boolean := False;
|
|
|
|
procedure Update_Result (Info : Discrete_Range_Info);
|
|
-- Initialize first remaining uninitialized element of Result.
|
|
-- Also set Next and Done.
|
|
|
|
-------------------
|
|
-- Update_Result --
|
|
-------------------
|
|
|
|
procedure Update_Result (Info : Discrete_Range_Info) is
|
|
begin
|
|
Result (Next) := Info;
|
|
if Next /= Part_Id'Last then
|
|
Next := Next + 1;
|
|
else
|
|
pragma Assert (not Done);
|
|
Done := True;
|
|
end if;
|
|
end Update_Result;
|
|
|
|
procedure Traverse_Discrete_Parts (Subtyp : Entity_Id);
|
|
-- Traverse the given subtype, looking for discrete parts.
|
|
-- For an array subtype of length N, the element subtype
|
|
-- is traversed N times. For a record subtype, traverse
|
|
-- each component's subtype (once). When a discrete part is
|
|
-- found, call Update_Result.
|
|
|
|
-----------------------------
|
|
-- Traverse_Discrete_Parts --
|
|
-----------------------------
|
|
|
|
procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is
|
|
begin
|
|
if Box_Value_Required (Subtyp) then
|
|
return;
|
|
end if;
|
|
|
|
if Is_Discrete_Type (Subtyp) then
|
|
Update_Result
|
|
((Low => Expr_Value (Type_Low_Bound (Subtyp)),
|
|
High => Expr_Value (Type_High_Bound (Subtyp))));
|
|
elsif Is_Array_Type (Subtyp) then
|
|
declare
|
|
Len : Nat;
|
|
begin
|
|
if Is_Constrained (Subtyp) then
|
|
Len := Static_Array_Length (Subtyp);
|
|
else
|
|
-- Length will be treated like a discriminant;
|
|
-- We could compute High more precisely as
|
|
-- 1 + Index_Subtype'Last - Index_Subtype'First
|
|
-- (we currently require that those bounds be
|
|
-- static, so this is an option), but only downside of
|
|
-- overshooting is if somebody wants to omit a
|
|
-- "when others" choice and exhaustively cover all
|
|
-- possibilities explicitly.
|
|
Update_Result
|
|
((Low => Uint_0,
|
|
High => Uint_2 ** Uint_32));
|
|
|
|
Len := Unconstrained_Array_Effective_Length
|
|
(Array_Type => Subtyp,
|
|
Case_Statement => Case_Statement);
|
|
end if;
|
|
for I in 1 .. Len loop
|
|
Traverse_Discrete_Parts (Component_Type (Subtyp));
|
|
end loop;
|
|
end;
|
|
elsif Is_Record_Type (Subtyp) then
|
|
if Has_Static_Discriminant_Constraint (Subtyp) then
|
|
|
|
-- The component range for a constrained discriminant
|
|
-- is a single value.
|
|
declare
|
|
Dc_Elmt : Elmt_Id :=
|
|
First_Elmt (Discriminant_Constraint (Subtyp));
|
|
Dc_Value : Uint;
|
|
begin
|
|
while Present (Dc_Elmt) loop
|
|
Dc_Value := Expr_Value (Node (Dc_Elmt));
|
|
Update_Result ((Low => Dc_Value,
|
|
High => Dc_Value));
|
|
|
|
Next_Elmt (Dc_Elmt);
|
|
end loop;
|
|
end;
|
|
|
|
-- Generate ranges for nondiscriminant components.
|
|
declare
|
|
Comp : Entity_Id := First_Component
|
|
(Base_Type (Subtyp));
|
|
begin
|
|
while Present (Comp) loop
|
|
Traverse_Discrete_Parts (Etype (Comp));
|
|
Next_Component (Comp);
|
|
end loop;
|
|
end;
|
|
else
|
|
-- Generate ranges for all components
|
|
declare
|
|
Comp : Entity_Id :=
|
|
First_Component_Or_Discriminant
|
|
(Base_Type (Subtyp));
|
|
begin
|
|
while Present (Comp) loop
|
|
Traverse_Discrete_Parts (Etype (Comp));
|
|
Next_Component_Or_Discriminant (Comp);
|
|
end loop;
|
|
end;
|
|
end if;
|
|
else
|
|
Error_Msg_N
|
|
("case selector type having a non-discrete non-record"
|
|
& " non-array subcomponent type not implemented",
|
|
Expression (Case_Statement));
|
|
end if;
|
|
end Traverse_Discrete_Parts;
|
|
|
|
begin
|
|
Traverse_Discrete_Parts (Case_Expr_Type);
|
|
pragma Assert (Done or else Serious_Errors_Detected > 0);
|
|
return Result;
|
|
end Component_Bounds_Info;
|
|
|
|
Component_Bounds : constant Composite_Range_Info
|
|
:= Component_Bounds_Info;
|
|
|
|
package Case_Bindings is
|
|
|
|
procedure Note_Binding
|
|
(Comp_Assoc : Node_Id;
|
|
Choice : Node_Id;
|
|
Alt : Node_Id);
|
|
-- Note_Binding is called once for each component association
|
|
-- that defines a binding (using either "A => B is X" or
|
|
-- "A => <X>" syntax);
|
|
|
|
procedure Check_Bindings;
|
|
-- After all calls to Note_Binding, check that bindings are
|
|
-- ok (e.g., check consistency among different choices of
|
|
-- one alternative).
|
|
|
|
end Case_Bindings;
|
|
|
|
procedure Refresh_Binding_Info (Aggr : Node_Id);
|
|
-- The parser records binding-related info in the tree.
|
|
-- The choice nodes that we see here might not be (will never be?)
|
|
-- the original nodes that were produced by the parser. The info
|
|
-- recorded by the parser is missing in that case, so this
|
|
-- procedure recovers it.
|
|
--
|
|
-- There are bugs here. In some cases involving nested aggregates,
|
|
-- the path back to the parser-created nodes is lost. In particular,
|
|
-- we may fail to detect an illegal case like
|
|
-- when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) =>
|
|
-- This should be rejected because it is binding X to both the
|
|
-- F1.Bb and to the F2.Bb subcomponents of the case selector.
|
|
-- It would be nice if the not-specific-to-pattern-matching
|
|
-- aggregate-processing code could remain unaware of the existence
|
|
-- of this binding-related info but perhaps that isn't possible.
|
|
|
|
--------------------------
|
|
-- Refresh_Binding_Info --
|
|
--------------------------
|
|
|
|
procedure Refresh_Binding_Info (Aggr : Node_Id) is
|
|
Orig_Aggr : constant Node_Id := Original_Node (Aggr);
|
|
Orig_Comp : Node_Id := First (Component_Associations (Orig_Aggr));
|
|
begin
|
|
if Aggr = Orig_Aggr then
|
|
return;
|
|
end if;
|
|
|
|
while Present (Orig_Comp) loop
|
|
if Nkind (Orig_Comp) = N_Component_Association
|
|
and then Binding_Chars (Orig_Comp) /= No_Name
|
|
then
|
|
if List_Length (Choices (Orig_Comp)) /= 1 then
|
|
-- Conceivably this could be checked during parsing,
|
|
-- but checking is easier here.
|
|
|
|
Error_Msg_N
|
|
("binding shared by multiple components", Orig_Comp);
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
Orig_Name : constant Name_Id :=
|
|
Chars (First (Choices (Orig_Comp)));
|
|
Comp : Node_Id := First (Component_Associations (Aggr));
|
|
Matching_Comp : Node_Id := Empty;
|
|
begin
|
|
while Present (Comp) loop
|
|
if Chars (First (Choices (Comp))) = Orig_Name then
|
|
pragma Assert (not Present (Matching_Comp));
|
|
Matching_Comp := Comp;
|
|
end if;
|
|
|
|
Next (Comp);
|
|
end loop;
|
|
|
|
pragma Assert (Present (Matching_Comp));
|
|
|
|
Set_Binding_Chars
|
|
(Matching_Comp,
|
|
Binding_Chars (Orig_Comp));
|
|
end;
|
|
end if;
|
|
|
|
Next (Orig_Comp);
|
|
end loop;
|
|
end Refresh_Binding_Info;
|
|
|
|
------------------
|
|
-- Parse_Choice --
|
|
------------------
|
|
|
|
function Parse_Choice (Choice : Node_Id;
|
|
Alt : Node_Id) return Choice_Range_Info
|
|
is
|
|
Result : Choice_Range_Info (Is_Others => False);
|
|
Ranges : Composite_Range_Info renames Result.Ranges;
|
|
Next_Part : Part_Id'Base range 1 .. Part_Id'Last + 1 := 1;
|
|
|
|
procedure Traverse_Choice (Expr : Node_Id);
|
|
-- Traverse a legal choice expression, looking for
|
|
-- values/ranges of discrete parts. Call Update_Result
|
|
-- for each.
|
|
|
|
procedure Update_Result (Discrete_Range : Discrete_Range_Info);
|
|
-- Initialize first remaining uninitialized element of Ranges.
|
|
-- Also set Next_Part.
|
|
|
|
procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id);
|
|
-- For each scalar part of the given component type, call
|
|
-- Update_Result with the full range for that scalar part.
|
|
-- This is used for both box components in aggregates and
|
|
-- for any inactive-variant components that do not appear in
|
|
-- a given aggregate.
|
|
|
|
-------------------
|
|
-- Update_Result --
|
|
-------------------
|
|
|
|
procedure Update_Result (Discrete_Range : Discrete_Range_Info) is
|
|
begin
|
|
Ranges (Next_Part) := Discrete_Range;
|
|
Next_Part := Next_Part + 1;
|
|
end Update_Result;
|
|
|
|
-------------------------------------
|
|
-- Update_Result_For_Full_Coverage --
|
|
-------------------------------------
|
|
|
|
procedure Update_Result_For_Full_Coverage (Comp_Type : Entity_Id)
|
|
is
|
|
begin
|
|
for Counter in 1 .. Scalar_Part_Count (Comp_Type) loop
|
|
Update_Result (Component_Bounds (Next_Part));
|
|
end loop;
|
|
end Update_Result_For_Full_Coverage;
|
|
|
|
---------------------
|
|
-- Traverse_Choice --
|
|
---------------------
|
|
|
|
procedure Traverse_Choice (Expr : Node_Id) is
|
|
begin
|
|
if Nkind (Expr) = N_Qualified_Expression then
|
|
Traverse_Choice (Expression (Expr));
|
|
|
|
elsif Nkind (Expr) = N_Type_Conversion
|
|
and then not Comes_From_Source (Expr)
|
|
then
|
|
if Expr /= Original_Node (Expr) then
|
|
Traverse_Choice (Original_Node (Expr));
|
|
else
|
|
Traverse_Choice (Expression (Expr));
|
|
end if;
|
|
|
|
elsif Nkind (Expr) = N_Aggregate then
|
|
if Is_Record_Type (Etype (Expr)) then
|
|
Refresh_Binding_Info (Aggr => Expr);
|
|
|
|
declare
|
|
Comp_Assoc : Node_Id :=
|
|
First (Component_Associations (Expr));
|
|
-- Aggregate has been normalized (components in
|
|
-- order, only one component per choice, etc.).
|
|
|
|
Comp_From_Type : Node_Id :=
|
|
First_Component_Or_Discriminant
|
|
(Base_Type (Etype (Expr)));
|
|
|
|
Saved_Next_Part : constant Part_Id := Next_Part;
|
|
begin
|
|
while Present (Comp_Assoc) loop
|
|
pragma Assert
|
|
(List_Length (Choices (Comp_Assoc)) = 1);
|
|
|
|
declare
|
|
Comp : constant Node_Id :=
|
|
Entity (First (Choices (Comp_Assoc)));
|
|
Comp_Seen : Boolean := False;
|
|
begin
|
|
loop
|
|
if Original_Record_Component (Comp) =
|
|
Original_Record_Component (Comp_From_Type)
|
|
then
|
|
Comp_Seen := True;
|
|
else
|
|
-- We have an aggregate of a type that
|
|
-- has a variant part (or has a
|
|
-- subcomponent type that has a variant
|
|
-- part) and we have to deal with a
|
|
-- component that is present in the type
|
|
-- but not in the aggregate (because the
|
|
-- component is in an inactive variant).
|
|
--
|
|
Update_Result_For_Full_Coverage
|
|
(Comp_Type => Etype (Comp_From_Type));
|
|
end if;
|
|
|
|
Comp_From_Type :=
|
|
Next_Component_Or_Discriminant
|
|
(Comp_From_Type);
|
|
|
|
exit when Comp_Seen;
|
|
end loop;
|
|
end;
|
|
|
|
declare
|
|
Comp_Type : constant Entity_Id :=
|
|
Etype (First (Choices (Comp_Assoc)));
|
|
begin
|
|
if Box_Value_Required (Comp_Type) then
|
|
-- This component is not allowed to
|
|
-- influence which alternative is
|
|
-- chosen; case choice must be box.
|
|
--
|
|
-- For example, component might be
|
|
-- of a real type or of an access type
|
|
-- or of a non-static discrete subtype.
|
|
if not Box_Present (Comp_Assoc) then
|
|
Error_Msg_N
|
|
("Non-box case choice component value" &
|
|
" of unsupported type/subtype",
|
|
Expression (Comp_Assoc));
|
|
end if;
|
|
elsif Box_Present (Comp_Assoc) then
|
|
-- Box matches all values
|
|
Update_Result_For_Full_Coverage
|
|
(Etype (First (Choices (Comp_Assoc))));
|
|
else
|
|
Traverse_Choice (Expression (Comp_Assoc));
|
|
end if;
|
|
end;
|
|
|
|
if Binding_Chars (Comp_Assoc) /= No_Name
|
|
then
|
|
Case_Bindings.Note_Binding
|
|
(Comp_Assoc => Comp_Assoc,
|
|
Choice => Choice,
|
|
Alt => Alt);
|
|
end if;
|
|
|
|
Next (Comp_Assoc);
|
|
end loop;
|
|
|
|
while Present (Comp_From_Type) loop
|
|
-- Deal with any trailing inactive-variant
|
|
-- components.
|
|
--
|
|
-- See earlier commment about calling
|
|
-- Update_Result_For_Full_Coverage for such
|
|
-- components.
|
|
|
|
Update_Result_For_Full_Coverage
|
|
(Comp_Type => Etype (Comp_From_Type));
|
|
|
|
Comp_From_Type :=
|
|
Next_Component_Or_Discriminant (Comp_From_Type);
|
|
end loop;
|
|
|
|
declare
|
|
Expr_Type : Entity_Id := Etype (Expr);
|
|
begin
|
|
if Has_Discriminants (Expr_Type) then
|
|
-- Avoid nonstatic choice expr types,
|
|
-- for which Scalar_Part_Count returns 0.
|
|
Expr_Type := Base_Type (Expr_Type);
|
|
end if;
|
|
|
|
pragma Assert
|
|
(Nat (Next_Part - Saved_Next_Part)
|
|
= Scalar_Part_Count (Expr_Type));
|
|
end;
|
|
end;
|
|
elsif Is_Array_Type (Etype (Expr)) then
|
|
if Is_Non_Empty_List (Component_Associations (Expr)) then
|
|
Error_Msg_N
|
|
("non-positional array aggregate as/within case "
|
|
& "choice not implemented", Expr);
|
|
end if;
|
|
|
|
if not Unconstrained_Array_Case
|
|
and then List_Length (Expressions (Expr))
|
|
/= Nat (Part_Id'Last)
|
|
then
|
|
Error_Msg_Uint_1 := UI_From_Int
|
|
(List_Length (Expressions (Expr)));
|
|
Error_Msg_Uint_2 := UI_From_Int (Int (Part_Id'Last));
|
|
Error_Msg_N
|
|
("array aggregate length ^ does not match length " &
|
|
"of statically constrained case selector ^", Expr);
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
Subexpr : Node_Id := First (Expressions (Expr));
|
|
begin
|
|
while Present (Subexpr) loop
|
|
Traverse_Choice (Subexpr);
|
|
Next (Subexpr);
|
|
end loop;
|
|
end;
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
elsif Nkind (Expr) = N_String_Literal then
|
|
if not Is_Array_Type (Etype (Expr)) then
|
|
Error_Msg_N
|
|
("User-defined string literal not allowed as/within"
|
|
& "case choice", Expr);
|
|
else
|
|
declare
|
|
Char_Type : constant Entity_Id :=
|
|
Root_Type (Component_Type (Etype (Expr)));
|
|
|
|
-- If the component type is not a standard character
|
|
-- type then this string lit should have already been
|
|
-- transformed into an aggregate in
|
|
-- Resolve_String_Literal.
|
|
--
|
|
pragma Assert (Is_Standard_Character_Type (Char_Type));
|
|
|
|
Str : constant String_Id := Strval (Expr);
|
|
Strlen : constant Nat := String_Length (Str);
|
|
Char_Val : Uint;
|
|
begin
|
|
if not Unconstrained_Array_Case
|
|
and then Strlen /= Nat (Part_Id'Last)
|
|
then
|
|
Error_Msg_Uint_1 := UI_From_Int (Strlen);
|
|
Error_Msg_Uint_2 := UI_From_Int
|
|
(Int (Part_Id'Last));
|
|
Error_Msg_N
|
|
("String literal length ^ does not match length" &
|
|
" of statically constrained case selector ^",
|
|
Expr);
|
|
return;
|
|
end if;
|
|
|
|
for Idx in 1 .. Strlen loop
|
|
Char_Val :=
|
|
UI_From_CC (Get_String_Char (Str, Idx));
|
|
Update_Result ((Low | High => Char_Val));
|
|
end loop;
|
|
end;
|
|
end if;
|
|
elsif Is_Discrete_Type (Etype (Expr)) then
|
|
if Nkind (Expr) in N_Has_Entity
|
|
and then Present (Entity (Expr))
|
|
and then Is_Type (Entity (Expr))
|
|
then
|
|
declare
|
|
Low : constant Node_Id :=
|
|
Type_Low_Bound (Entity (Expr));
|
|
High : constant Node_Id :=
|
|
Type_High_Bound (Entity (Expr));
|
|
begin
|
|
Update_Result ((Low => Expr_Value (Low),
|
|
High => Expr_Value (High)));
|
|
end;
|
|
else
|
|
pragma Assert (Compile_Time_Known_Value (Expr));
|
|
Update_Result ((Low | High => Expr_Value (Expr)));
|
|
end if;
|
|
elsif Nkind (Expr) in N_Has_Entity
|
|
and then Present (Entity (Expr))
|
|
and then Ekind (Entity (Expr)) = E_Constant
|
|
then
|
|
Traverse_Choice (Expression (Parent (Entity (Expr))));
|
|
elsif Nkind (Original_Node (Expr))
|
|
in N_Aggregate | N_String_Literal
|
|
then
|
|
Traverse_Choice (Original_Node (Expr));
|
|
else
|
|
Error_Msg_N
|
|
("non-aggregate case choice (or subexpression thereof)"
|
|
& " that is not of a discrete type not implemented",
|
|
Expr);
|
|
end if;
|
|
end Traverse_Choice;
|
|
|
|
-- Start of processing for Parse_Choice
|
|
|
|
begin
|
|
if Nkind (Choice) = N_Others_Choice then
|
|
return (Is_Others => True);
|
|
end if;
|
|
|
|
if Unconstrained_Array_Case then
|
|
-- Treat length like a discriminant
|
|
Update_Result ((Low | High =>
|
|
UI_From_Int (Array_Choice_Length (Choice))));
|
|
end if;
|
|
|
|
Traverse_Choice (Choice);
|
|
|
|
if Unconstrained_Array_Case then
|
|
-- This is somewhat tricky. Suppose we are casing on String,
|
|
-- the longest choice in the case statement is length 10, and
|
|
-- the choice we are looking at now is of length 6. We fill
|
|
-- in the trailing 4 slots here.
|
|
while Next_Part <= Part_Id'Last loop
|
|
Update_Result_For_Full_Coverage
|
|
(Comp_Type => Component_Type (Case_Expr_Type));
|
|
end loop;
|
|
end if;
|
|
|
|
-- Avoid returning uninitialized garbage in error case
|
|
if Next_Part /= Part_Id'Last + 1 then
|
|
pragma Assert (Serious_Errors_Detected > 0);
|
|
Result.Ranges := (others => (Low => Uint_1, High => Uint_0));
|
|
end if;
|
|
|
|
return Result;
|
|
end Parse_Choice;
|
|
|
|
package body Case_Bindings is
|
|
|
|
type Binding is record
|
|
Comp_Assoc : Node_Id;
|
|
Choice : Node_Id;
|
|
Alt : Node_Id;
|
|
end record;
|
|
|
|
type Binding_Index is new Natural;
|
|
|
|
package Case_Bindings_Table is new Table.Table
|
|
(Table_Component_Type => Binding,
|
|
Table_Index_Type => Binding_Index,
|
|
Table_Low_Bound => 1,
|
|
Table_Initial => 16,
|
|
Table_Increment => 64,
|
|
Table_Name => "Composite_Case_Ops.Case_Bindings");
|
|
|
|
------------------
|
|
-- Note_Binding --
|
|
------------------
|
|
|
|
procedure Note_Binding
|
|
(Comp_Assoc : Node_Id;
|
|
Choice : Node_Id;
|
|
Alt : Node_Id)
|
|
is
|
|
begin
|
|
Case_Bindings_Table.Append
|
|
((Comp_Assoc => Comp_Assoc,
|
|
Choice => Choice,
|
|
Alt => Alt));
|
|
end Note_Binding;
|
|
|
|
--------------------
|
|
-- Check_Bindings --
|
|
--------------------
|
|
|
|
procedure Check_Bindings
|
|
is
|
|
use Case_Bindings_Table;
|
|
|
|
function Binding_Subtype (Idx : Binding_Index;
|
|
Tab : Table_Type)
|
|
return Entity_Id is
|
|
(Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));
|
|
|
|
procedure Declare_Binding_Objects
|
|
(Alt_Start : Binding_Index;
|
|
Alt : Node_Id;
|
|
First_Choice_Bindings : Natural;
|
|
Tab : Table_Type);
|
|
-- Declare the binding objects for a given alternative
|
|
|
|
------------------------------
|
|
-- Declare_Binding_Objects --
|
|
------------------------------
|
|
|
|
procedure Declare_Binding_Objects
|
|
(Alt_Start : Binding_Index;
|
|
Alt : Node_Id;
|
|
First_Choice_Bindings : Natural;
|
|
Tab : Table_Type)
|
|
is
|
|
Loc : constant Source_Ptr := Sloc (Alt);
|
|
Declarations : constant List_Id := New_List;
|
|
Decl : Node_Id;
|
|
Obj_Type : Entity_Id;
|
|
Def_Id : Entity_Id;
|
|
begin
|
|
for FC_Idx in Alt_Start ..
|
|
Alt_Start + Binding_Index (First_Choice_Bindings - 1)
|
|
loop
|
|
Obj_Type := Binding_Subtype (FC_Idx, Tab);
|
|
Def_Id := Make_Defining_Identifier
|
|
(Loc,
|
|
Binding_Chars (Tab (FC_Idx).Comp_Assoc));
|
|
|
|
-- Either make a copy or rename the original. At a
|
|
-- minimum, we do not want a copy if it would need
|
|
-- finalization. Copies may also introduce problems
|
|
-- if default init can have side effects (although we
|
|
-- could suppress such default initialization).
|
|
-- We have to make a copy in any cases where
|
|
-- Unrestricted_Access doesn't work.
|
|
--
|
|
-- This is where the copy-or-rename decision is made.
|
|
-- In many cases either way would work and so we have
|
|
-- some flexibility here.
|
|
|
|
if not Is_By_Copy_Type (Obj_Type) then
|
|
-- Generate
|
|
-- type Ref
|
|
-- is access constant Obj_Type;
|
|
-- Ptr : Ref := <some bogus value>;
|
|
-- Obj : Obj_Type renames Ptr.all;
|
|
--
|
|
-- Initialization of Ptr will be generated later
|
|
-- during expansion.
|
|
|
|
declare
|
|
Ptr_Type : constant Entity_Id :=
|
|
Make_Temporary (Loc, 'P');
|
|
|
|
Ptr_Type_Def : constant Node_Id :=
|
|
Make_Access_To_Object_Definition (Loc,
|
|
All_Present => True,
|
|
Subtype_Indication =>
|
|
New_Occurrence_Of (Obj_Type, Loc));
|
|
|
|
Ptr_Type_Decl : constant Node_Id :=
|
|
Make_Full_Type_Declaration (Loc,
|
|
Ptr_Type,
|
|
Type_Definition => Ptr_Type_Def);
|
|
|
|
Ptr_Obj : constant Entity_Id :=
|
|
Make_Temporary (Loc, 'T');
|
|
|
|
-- We will generate initialization code for this
|
|
-- object later (during expansion) but in the
|
|
-- meantime we don't want the dereference that
|
|
-- is generated a few lines below here to be
|
|
-- transformed into a Raise_C_E. To prevent this,
|
|
-- we provide a bogus initial value here; this
|
|
-- initial value will be removed later during
|
|
-- expansion.
|
|
|
|
Ptr_Obj_Decl : constant Node_Id :=
|
|
Make_Object_Declaration
|
|
(Loc, Ptr_Obj,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Ptr_Type, Loc),
|
|
Expression =>
|
|
Unchecked_Convert_To
|
|
(Ptr_Type,
|
|
Make_Integer_Literal (Loc, 5432)));
|
|
begin
|
|
Mutate_Ekind (Ptr_Type, E_Access_Type);
|
|
|
|
-- in effect, Storage_Size => 0
|
|
Set_No_Pool_Assigned (Ptr_Type);
|
|
|
|
Set_Is_Access_Constant (Ptr_Type);
|
|
|
|
-- We could set Ptr_Type'Alignment here if that
|
|
-- ever turns out to be needed for renaming a
|
|
-- misaligned subcomponent.
|
|
|
|
Mutate_Ekind (Ptr_Obj, E_Variable);
|
|
Set_Etype (Ptr_Obj, Ptr_Type);
|
|
|
|
Decl :=
|
|
Make_Object_Renaming_Declaration
|
|
(Loc, Def_Id,
|
|
Subtype_Mark =>
|
|
New_Occurrence_Of (Obj_Type, Loc),
|
|
Name =>
|
|
Make_Explicit_Dereference
|
|
(Loc, New_Occurrence_Of (Ptr_Obj, Loc)));
|
|
|
|
Append_To (Declarations, Ptr_Type_Decl);
|
|
Append_To (Declarations, Ptr_Obj_Decl);
|
|
end;
|
|
else
|
|
Decl := Make_Object_Declaration
|
|
(Sloc => Loc,
|
|
Defining_Identifier => Def_Id,
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Obj_Type, Loc));
|
|
end if;
|
|
Append_To (Declarations, Decl);
|
|
end loop;
|
|
|
|
declare
|
|
Old_Statements : constant List_Id := Statements (Alt);
|
|
New_Statements : constant List_Id := New_List;
|
|
|
|
Block_Statement : constant Node_Id :=
|
|
Make_Block_Statement (Sloc => Loc,
|
|
Declarations => Declarations,
|
|
Handled_Statement_Sequence =>
|
|
Make_Handled_Sequence_Of_Statements
|
|
(Loc, Old_Statements),
|
|
Has_Created_Identifier => True);
|
|
begin
|
|
Append_To (New_Statements, Block_Statement);
|
|
Set_Statements (Alt, New_Statements);
|
|
end;
|
|
end Declare_Binding_Objects;
|
|
begin
|
|
if Last = 0 then
|
|
-- no bindings to check
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
Tab : Table_Type
|
|
renames Case_Bindings_Table.Table (1 .. Last);
|
|
|
|
function Same_Id (Idx1, Idx2 : Binding_Index)
|
|
return Boolean is (
|
|
Binding_Chars (Tab (Idx1).Comp_Assoc) =
|
|
Binding_Chars (Tab (Idx2).Comp_Assoc));
|
|
begin
|
|
-- Verify that elements with given choice or alt value
|
|
-- are contiguous, and that elements with equal
|
|
-- choice values have same alt value.
|
|
|
|
for Idx1 in 2 .. Tab'Last loop
|
|
if Tab (Idx1 - 1).Choice /= Tab (Idx1).Choice then
|
|
pragma Assert
|
|
(for all Idx2 in Idx1 + 1 .. Tab'Last =>
|
|
Tab (Idx2).Choice /= Tab (Idx1 - 1).Choice);
|
|
else
|
|
pragma Assert (Tab (Idx1 - 1).Alt = Tab (Idx1).Alt);
|
|
end if;
|
|
if Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt then
|
|
pragma Assert
|
|
(for all Idx2 in Idx1 + 1 .. Tab'Last =>
|
|
Tab (Idx2).Alt /= Tab (Idx1 - 1).Alt);
|
|
end if;
|
|
end loop;
|
|
|
|
-- Check for user errors:
|
|
-- 1) Two choices for a given alternative shall define the
|
|
-- same set of names. Can't have
|
|
-- when (<X>, 0) | (0, <Y>) =>
|
|
-- 2) A choice shall not define a name twice. Can't have
|
|
-- when (A => <X>, B => <X>, C => 0) =>
|
|
-- 3) Two definitions of a name within one alternative
|
|
-- shall have statically matching component subtypes.
|
|
-- Can't have
|
|
-- type R is record Int : Integer;
|
|
-- Nat : Natural; end record;
|
|
-- case R'(...) is
|
|
-- when (<X>, 1) | (1, <X>) =>
|
|
-- 4) A given binding shall match only one value.
|
|
-- Can't have
|
|
-- (Fld1 | Fld2 => (Fld => <X>))
|
|
-- For now, this is enforced *very* conservatively
|
|
-- with respect to arrays - a binding cannot match
|
|
-- any part of an array. This is temporary.
|
|
|
|
for Idx1 in Tab'Range loop
|
|
if Idx1 = 1
|
|
or else Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt
|
|
then
|
|
-- Process one alternative
|
|
declare
|
|
Alt_Start : constant Binding_Index := Idx1;
|
|
Alt : constant Node_Id := Tab (Alt_Start).Alt;
|
|
|
|
First_Choice : constant Node_Id :=
|
|
Nlists.First (Discrete_Choices (Alt));
|
|
First_Choice_Bindings : Natural := 0;
|
|
begin
|
|
-- Check for duplicates within one choice,
|
|
-- and for choices with no bindings.
|
|
|
|
if First_Choice /= Tab (Alt_Start).Choice then
|
|
Error_Msg_N ("binding(s) missing for choice",
|
|
First_Choice);
|
|
return;
|
|
end if;
|
|
|
|
declare
|
|
Current_Choice : Node_Id := First_Choice;
|
|
Choice_Start : Binding_Index := Alt_Start;
|
|
begin
|
|
for Idx2 in Alt_Start .. Tab'Last loop
|
|
exit when Tab (Idx2).Alt /= Alt;
|
|
if Tab (Idx2).Choice = Current_Choice then
|
|
for Idx3 in Choice_Start .. Idx2 - 1 loop
|
|
if Same_Id (Idx2, Idx3)
|
|
then
|
|
Error_Msg_N
|
|
("duplicate binding in choice",
|
|
Current_Choice);
|
|
return;
|
|
end if;
|
|
end loop;
|
|
else
|
|
Next (Current_Choice);
|
|
pragma Assert (Present (Current_Choice));
|
|
Choice_Start := Idx2;
|
|
|
|
if Tab (Idx2).Choice /= Current_Choice
|
|
then
|
|
Error_Msg_N
|
|
("binding(s) missing for choice",
|
|
Current_Choice);
|
|
return;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If we made it through all the bindings
|
|
-- for this alternative but didn't make it
|
|
-- to the last choice, then bindings are
|
|
-- missing for all remaining choices.
|
|
-- We only complain about the first one.
|
|
|
|
if Present (Next (Current_Choice)) then
|
|
Error_Msg_N
|
|
("binding(s) missing for choice",
|
|
Next (Current_Choice));
|
|
return;
|
|
end if;
|
|
end;
|
|
|
|
-- Count bindings for first choice of alternative
|
|
|
|
for FC_Idx in Alt_Start .. Tab'Last loop
|
|
exit when Tab (FC_Idx).Choice /= First_Choice;
|
|
First_Choice_Bindings :=
|
|
First_Choice_Bindings + 1;
|
|
end loop;
|
|
|
|
declare
|
|
Current_Choice : Node_Id := First_Choice;
|
|
Current_Choice_Bindings : Natural := 0;
|
|
begin
|
|
for Idx2 in Alt_Start .. Tab'Last loop
|
|
exit when Tab (Idx2).Alt /= Alt;
|
|
|
|
-- If starting a new choice
|
|
|
|
if Tab (Idx2).Choice /= Current_Choice then
|
|
|
|
-- Check count for choice just finished
|
|
|
|
if Current_Choice_Bindings
|
|
/= First_Choice_Bindings
|
|
then
|
|
Error_Msg_N
|
|
("subsequent choice has different"
|
|
& " number of bindings than first"
|
|
& " choice", Current_Choice);
|
|
end if;
|
|
|
|
Current_Choice := Tab (Idx2).Choice;
|
|
Current_Choice_Bindings := 1;
|
|
|
|
-- Remember that Alt has both one or more
|
|
-- bindings and two or more choices; we'll
|
|
-- need to know this during expansion.
|
|
|
|
Set_Multidefined_Bindings (Alt, True);
|
|
else
|
|
Current_Choice_Bindings :=
|
|
Current_Choice_Bindings + 1;
|
|
end if;
|
|
|
|
-- Check that first choice has binding with
|
|
-- matching name; check subtype consistency.
|
|
|
|
declare
|
|
Found : Boolean := False;
|
|
begin
|
|
for FC_Idx in
|
|
Alt_Start ..
|
|
Alt_Start + Binding_Index
|
|
(First_Choice_Bindings - 1)
|
|
loop
|
|
if Same_Id (Idx2, FC_Idx) then
|
|
if not Subtypes_Statically_Match
|
|
(Binding_Subtype (Idx2, Tab),
|
|
Binding_Subtype (FC_Idx, Tab))
|
|
then
|
|
Error_Msg_N
|
|
("subtype of binding in "
|
|
& "subsequent choice does not "
|
|
& "match that in first choice",
|
|
Tab (Idx2).Comp_Assoc);
|
|
end if;
|
|
Found := True;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
if not Found then
|
|
Error_Msg_N
|
|
("binding defined in subsequent "
|
|
& "choice not defined in first "
|
|
& "choice", Current_Choice);
|
|
end if;
|
|
end;
|
|
|
|
-- Check for illegal repeated binding
|
|
-- via an enclosing aggregate, as in
|
|
-- (F1 | F2 => (F3 => Natural is X,
|
|
-- F4 => Natural))
|
|
-- where the inner aggregate would be ok.
|
|
|
|
declare
|
|
Rover : Node_Id := Tab (Idx2).Comp_Assoc;
|
|
begin
|
|
while Rover /= Tab (Idx2).Choice loop
|
|
Rover :=
|
|
(if Is_List_Member (Rover) then
|
|
Parent (List_Containing (Rover))
|
|
else Parent (Rover));
|
|
pragma Assert (Present (Rover));
|
|
if Nkind (Rover)
|
|
= N_Component_Association
|
|
and then List_Length (Choices (Rover))
|
|
> 1
|
|
then
|
|
Error_Msg_N
|
|
("binding shared by multiple "
|
|
& "enclosing components",
|
|
Tab (Idx2).Comp_Assoc);
|
|
end if;
|
|
end loop;
|
|
end;
|
|
end loop;
|
|
end;
|
|
|
|
-- Construct the (unanalyzed) declarations for
|
|
-- the current alternative. Then analyze them.
|
|
|
|
if First_Choice_Bindings > 0 then
|
|
Declare_Binding_Objects
|
|
(Alt_Start => Alt_Start,
|
|
Alt => Alt,
|
|
First_Choice_Bindings =>
|
|
First_Choice_Bindings,
|
|
Tab => Tab);
|
|
end if;
|
|
end;
|
|
end if;
|
|
end loop;
|
|
end;
|
|
end Check_Bindings;
|
|
end Case_Bindings;
|
|
|
|
function Choice_Bounds_Info return Choices_Range_Info;
|
|
-- Returns mapping from any given Choice_Id value to that choice's
|
|
-- component-to-range map.
|
|
|
|
------------------------
|
|
-- Choice_Bounds_Info --
|
|
------------------------
|
|
|
|
function Choice_Bounds_Info return Choices_Range_Info is
|
|
Result : Choices_Range_Info;
|
|
Alt : Node_Id := First (Alternatives (Case_Statement));
|
|
C_Id : Choice_Id := 1;
|
|
begin
|
|
while Present (Alt) loop
|
|
declare
|
|
Choice : Node_Id := First (Discrete_Choices (Alt));
|
|
begin
|
|
while Present (Choice) loop
|
|
Result (C_Id) := Parse_Choice (Choice, Alt => Alt);
|
|
|
|
Next (Choice);
|
|
if C_Id /= Choice_Id'Last then
|
|
C_Id := C_Id + 1;
|
|
end if;
|
|
end loop;
|
|
end;
|
|
Next (Alt);
|
|
end loop;
|
|
|
|
pragma Assert (C_Id = Choice_Id'Last);
|
|
|
|
-- No more calls to Note_Binding, so time for checks.
|
|
Case_Bindings.Check_Bindings;
|
|
|
|
return Result;
|
|
end Choice_Bounds_Info;
|
|
|
|
Choices_Bounds : constant Choices_Range_Info := Choice_Bounds_Info;
|
|
|
|
package body Value_Sets is
|
|
use GNAT;
|
|
|
|
function Hash (Key : Uint) return Bucket_Range_Type is
|
|
(Bucket_Range_Type
|
|
(UI_To_Int (Key mod (Uint_2 ** Uint_31))));
|
|
|
|
package Uint_Sets is new GNAT.Sets.Membership_Sets
|
|
(Uint, "=", Hash);
|
|
|
|
type Representative_Values_Array is
|
|
array (Part_Id) of Uint_Sets.Membership_Set;
|
|
|
|
function Representative_Values_Init
|
|
return Representative_Values_Array;
|
|
-- Select the representative values for each Part_Id value.
|
|
-- This function is called exactly once, immediately after it
|
|
-- is declared.
|
|
|
|
--------------------------------
|
|
-- Representative_Values_Init --
|
|
--------------------------------
|
|
|
|
function Representative_Values_Init
|
|
return Representative_Values_Array
|
|
is
|
|
-- For each range of each choice (as well as the range for the
|
|
-- component subtype, which is handled in the first loop),
|
|
-- insert the low bound of the range and the successor of
|
|
-- the high bound into the corresponding R_V element.
|
|
--
|
|
-- The idea we are trying to capture here is somewhat tricky.
|
|
-- Given an arbitrary point P1 in the Cartesian product
|
|
-- of the Component_Bounds sets, we want to be able
|
|
-- to map that to a point P2 in the (smaller) Cartesian product
|
|
-- of the Representative_Values sets that has the property
|
|
-- that for every choice of the case statement, P1 matches
|
|
-- the choice if and only if P2 also matches. Given that,
|
|
-- we can implement the overlapping/containment/etc. rules
|
|
-- safely by just looking at (using brute force enumeration)
|
|
-- the (smaller) Cartesian product of the R_V sets.
|
|
-- We are never going to actually perform this point-to-point
|
|
-- mapping - just the fact that it exists is enough to ensure
|
|
-- we can safely look at just the R_V sets.
|
|
--
|
|
-- The desired mapping can be implemented by mapping a point
|
|
-- P1 to a point P2 by reducing each of P1's coordinates down
|
|
-- to the largest element of the corresponding R_V set that is
|
|
-- less than or equal to the original coordinate value (such
|
|
-- an element Y will always exist because the R_V set for a
|
|
-- given component always includes the low bound of the
|
|
-- component subtype). It then suffices to show that every
|
|
-- choice in the case statement yields the same Boolean result
|
|
-- for P1 as for P2.
|
|
--
|
|
-- Suppose the contrary. Then there is some particular
|
|
-- coordinate position X (i.e., a Part_Id value) and some
|
|
-- choice C where exactly one of P1(X) and P2(X) belongs to
|
|
-- the (contiguous) range associated with C(X); call that
|
|
-- range L .. H. We know that P2(X) <= P1(X) because the
|
|
-- mapping never increases coordinate values. Consider three
|
|
-- cases: P1(X) lies within the L .. H range, or it is greater
|
|
-- than H, or it is lower than L.
|
|
-- The third case is impossible because reducing a value that
|
|
-- is less than L can only produce another such value,
|
|
-- violating the "exactly one" assumption. The second
|
|
-- case is impossible because L belongs to the corresponding
|
|
-- R_V set, so P2(X) >= L and both values belong to the
|
|
-- range, again violating the "exactly one" assumption.
|
|
-- Finally, the third case is impossible because H+1 belongs
|
|
-- to the corresponding R_V set, so P2(X) > H, so neither
|
|
-- value belongs to the range, again violating the "exactly
|
|
-- one" assumption. So our initial supposition was wrong. QED.
|
|
|
|
use Uint_Sets;
|
|
|
|
Result : constant Representative_Values_Array
|
|
:= (others => Uint_Sets.Create (Initial_Size => 32));
|
|
|
|
procedure Insert_Representative (Value : Uint; P : Part_Id);
|
|
-- Insert the given Value into the representative values set
|
|
-- for the given component if it belongs to the component's
|
|
-- subtype. Otherwise, do nothing.
|
|
|
|
---------------------------
|
|
-- Insert_Representative --
|
|
---------------------------
|
|
|
|
procedure Insert_Representative (Value : Uint; P : Part_Id) is
|
|
begin
|
|
if Value >= Component_Bounds (P).Low and
|
|
Value <= Component_Bounds (P).High
|
|
then
|
|
Insert (Result (P), Value);
|
|
end if;
|
|
end Insert_Representative;
|
|
|
|
begin
|
|
for P in Part_Id loop
|
|
Insert_Representative (Component_Bounds (P).Low, P);
|
|
end loop;
|
|
for C of Choices_Bounds loop
|
|
if not C.Is_Others then
|
|
for P in Part_Id loop
|
|
if C.Ranges (P).Low <= C.Ranges (P).High then
|
|
Insert_Representative (C.Ranges (P).Low, P);
|
|
Insert_Representative (C.Ranges (P).High + 1, P);
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
return Result;
|
|
end Representative_Values_Init;
|
|
|
|
Representative_Values : constant Representative_Values_Array
|
|
:= Representative_Values_Init;
|
|
-- We want to avoid looking at every point in the Cartesian
|
|
-- product of all component values. Instead we select, for each
|
|
-- component, a set of representative values and then look only
|
|
-- at the Cartesian product of those sets. A single value can
|
|
-- safely represent a larger enclosing interval if every choice
|
|
-- for that component either completely includes or completely
|
|
-- excludes the interval. The elements of this array will be
|
|
-- populated by a call to Initialize_Representative_Values and
|
|
-- will remain constant after that.
|
|
|
|
type Value_Index_Base is new Natural;
|
|
|
|
function Value_Index_Count return Value_Index_Base;
|
|
-- Returns the product of the sizes of the Representative_Values
|
|
-- sets (i.e., the size of the Cartesian product of the sets).
|
|
-- May return zero if one of the sets is empty.
|
|
-- This function is called exactly once, immediately after it
|
|
-- is declared.
|
|
|
|
-----------------------
|
|
-- Value_Index_Count --
|
|
-----------------------
|
|
|
|
function Value_Index_Count return Value_Index_Base is
|
|
Result : Value_Index_Base := 1;
|
|
begin
|
|
for Set of Representative_Values loop
|
|
Result := Result * Value_Index_Base (Uint_Sets.Size (Set));
|
|
end loop;
|
|
return Result;
|
|
exception
|
|
when Constraint_Error =>
|
|
Error_Msg_N
|
|
("Capacity exceeded in compiling case statement with"
|
|
& " composite selector type", Case_Statement);
|
|
raise;
|
|
end Value_Index_Count;
|
|
|
|
Max_Value_Index : constant Value_Index_Base := Value_Index_Count;
|
|
|
|
subtype Value_Index is Value_Index_Base range 1 .. Max_Value_Index;
|
|
type Value_Index_Set is array (Value_Index) of Boolean;
|
|
|
|
package Value_Index_Set_Table is new Table.Table
|
|
(Table_Component_Type => Value_Index_Set,
|
|
Table_Index_Type => Value_Set,
|
|
Table_Low_Bound => 1,
|
|
Table_Initial => 16,
|
|
Table_Increment => 100,
|
|
Table_Name => "Composite_Case_Ops.Value_Sets");
|
|
-- A nonzero Value_Set value is an index into this table.
|
|
|
|
function Indexed (Index : Value_Set) return Value_Index_Set
|
|
is (Value_Index_Set_Table.Table.all (Index));
|
|
|
|
function Allocate_Table_Element (Initial_Value : Value_Index_Set)
|
|
return Value_Set;
|
|
-- Allocate and initialize a new table element; return its index.
|
|
|
|
----------------------------
|
|
-- Allocate_Table_Element --
|
|
----------------------------
|
|
|
|
function Allocate_Table_Element (Initial_Value : Value_Index_Set)
|
|
return Value_Set
|
|
is
|
|
use Value_Index_Set_Table;
|
|
begin
|
|
Append (Initial_Value);
|
|
return Last;
|
|
end Allocate_Table_Element;
|
|
|
|
procedure Assign_Table_Element (Index : Value_Set;
|
|
Value : Value_Index_Set);
|
|
-- Assign specified value to specified table element.
|
|
|
|
--------------------------
|
|
-- Assign_Table_Element --
|
|
--------------------------
|
|
|
|
procedure Assign_Table_Element (Index : Value_Set;
|
|
Value : Value_Index_Set)
|
|
is
|
|
begin
|
|
Value_Index_Set_Table.Table.all (Index) := Value;
|
|
end Assign_Table_Element;
|
|
|
|
-------------
|
|
-- Compare --
|
|
-------------
|
|
|
|
function Compare (S1, S2 : Value_Set) return Set_Comparison is
|
|
begin
|
|
if S1 = Empty or S2 = Empty then
|
|
return Disjoint;
|
|
elsif Indexed (S1) = Indexed (S2) then
|
|
return Equal;
|
|
else
|
|
declare
|
|
Intersection : constant Value_Index_Set
|
|
:= Indexed (S1) and Indexed (S2);
|
|
begin
|
|
if (for all Flag of Intersection => not Flag) then
|
|
return Disjoint;
|
|
elsif Intersection = Indexed (S1) then
|
|
return Contained_By;
|
|
elsif Intersection = Indexed (S2) then
|
|
return Contains;
|
|
else
|
|
return Overlaps;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Compare;
|
|
|
|
-------------------------
|
|
-- Complement_Is_Empty --
|
|
-------------------------
|
|
|
|
function Complement_Is_Empty (Set : Value_Set) return Boolean
|
|
is (Set /= Empty
|
|
and then (for all Flag of Indexed (Set) => Flag));
|
|
|
|
---------------------
|
|
-- Free_Value_Sets --
|
|
---------------------
|
|
procedure Free_Value_Sets is
|
|
begin
|
|
Value_Index_Set_Table.Free;
|
|
end Free_Value_Sets;
|
|
|
|
-----------
|
|
-- Union --
|
|
-----------
|
|
|
|
procedure Union (Target : in out Value_Set; Source : Value_Set) is
|
|
begin
|
|
if Source /= Empty then
|
|
if Target = Empty then
|
|
Target := Allocate_Table_Element (Indexed (Source));
|
|
else
|
|
Assign_Table_Element
|
|
(Target, Indexed (Target) or Indexed (Source));
|
|
end if;
|
|
end if;
|
|
end Union;
|
|
|
|
------------
|
|
-- Remove --
|
|
------------
|
|
|
|
procedure Remove (Target : in out Value_Set; Source : Value_Set) is
|
|
begin
|
|
if Source /= Empty and Target /= Empty then
|
|
Assign_Table_Element
|
|
(Target, Indexed (Target) and not Indexed (Source));
|
|
if (for all V of Indexed (Target) => not V) then
|
|
Target := Empty;
|
|
end if;
|
|
end if;
|
|
end Remove;
|
|
|
|
---------------------
|
|
-- Matching_Values --
|
|
---------------------
|
|
|
|
function Matching_Values
|
|
(Info : Composite_Range_Info) return Value_Set
|
|
is
|
|
Matches : Value_Index_Set;
|
|
Next_Index : Value_Index := 1;
|
|
Done : Boolean := False;
|
|
Point : array (Part_Id) of Uint;
|
|
|
|
procedure Test_Point_For_Match;
|
|
-- Point identifies a point in the Cartesian product of the
|
|
-- representative value sets. Record whether that Point
|
|
-- belongs to the product-of-ranges specified by Info.
|
|
|
|
--------------------------
|
|
-- Test_Point_For_Match --
|
|
--------------------------
|
|
|
|
procedure Test_Point_For_Match is
|
|
function In_Range (Val : Uint; Rang : Discrete_Range_Info)
|
|
return Boolean is
|
|
((Rang.Low <= Val) and then (Val <= Rang.High));
|
|
begin
|
|
pragma Assert (not Done);
|
|
Matches (Next_Index) :=
|
|
(for all P in Part_Id => In_Range (Point (P), Info (P)));
|
|
if Next_Index = Matches'Last then
|
|
Done := True;
|
|
else
|
|
Next_Index := Next_Index + 1;
|
|
end if;
|
|
end Test_Point_For_Match;
|
|
|
|
procedure Test_Points (P : Part_Id);
|
|
-- Iterate over the Cartesian product of the representative
|
|
-- value sets, calling Test_Point_For_Match for each point.
|
|
|
|
-----------------
|
|
-- Test_Points --
|
|
-----------------
|
|
|
|
procedure Test_Points (P : Part_Id) is
|
|
use Uint_Sets;
|
|
Iter : Iterator := Iterate (Representative_Values (P));
|
|
begin
|
|
-- We could traverse here in sorted order, as opposed to
|
|
-- whatever order the set iterator gives us.
|
|
-- No need for that as long as every iteration over
|
|
-- a given representative values set yields the same order.
|
|
-- Not sorting is more efficient, but it makes it harder to
|
|
-- interpret a Value_Index_Set bit vector when debugging.
|
|
|
|
while Has_Next (Iter) loop
|
|
Next (Iter, Point (P));
|
|
|
|
-- If we have finished building up a Point value, then
|
|
-- test it for matching. Otherwise, recurse to continue
|
|
-- building up a point value.
|
|
|
|
if P = Part_Id'Last then
|
|
Test_Point_For_Match;
|
|
else
|
|
Test_Points (P + 1);
|
|
end if;
|
|
end loop;
|
|
end Test_Points;
|
|
|
|
begin
|
|
Test_Points (1);
|
|
if (for all Flag of Matches => not Flag) then
|
|
return Empty;
|
|
end if;
|
|
return Allocate_Table_Element (Matches);
|
|
end Matching_Values;
|
|
|
|
end Value_Sets;
|
|
|
|
--------------
|
|
-- Analysis --
|
|
--------------
|
|
|
|
function Analysis return Choices_Info is
|
|
Result : Choices_Info;
|
|
Alt : Node_Id := First (Alternatives (Case_Statement));
|
|
A_Id : Alternative_Id := 1;
|
|
C_Id : Choice_Id := 1;
|
|
begin
|
|
while Present (Alt) loop
|
|
declare
|
|
Choice : Node_Id := First (Discrete_Choices (Alt));
|
|
begin
|
|
while Present (Choice) loop
|
|
if Nkind (Choice) = N_Others_Choice then
|
|
pragma Assert (Choices_Bounds (C_Id).Is_Others);
|
|
Result (C_Id) :=
|
|
(Alternative => A_Id,
|
|
Is_Others => True);
|
|
else
|
|
Result (C_Id) :=
|
|
(Alternative => A_Id,
|
|
Is_Others => False,
|
|
Matches => Value_Sets.Matching_Values
|
|
(Choices_Bounds (C_Id).Ranges));
|
|
end if;
|
|
Next (Choice);
|
|
if C_Id /= Choice_Id'Last then
|
|
C_Id := C_Id + 1;
|
|
end if;
|
|
end loop;
|
|
end;
|
|
|
|
Next (Alt);
|
|
if A_Id /= Alternative_Id'Last then
|
|
A_Id := A_Id + 1;
|
|
end if;
|
|
end loop;
|
|
|
|
pragma Assert (A_Id = Alternative_Id'Last);
|
|
pragma Assert (C_Id = Choice_Id'Last);
|
|
|
|
return Result;
|
|
end Analysis;
|
|
|
|
end Choice_Analysis;
|
|
|
|
end Composite_Case_Ops;
|
|
|
|
--------------------------
|
|
-- 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. The
|
|
-- returned value has its Is_Static_Expression flag set to true.
|
|
|
|
------------------
|
|
-- 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 Value1 = Value2 then
|
|
if Is_Integer_Type (Choice_Type) then
|
|
Lit_Node := Make_Integer_Literal (Loc, Value1);
|
|
Set_Etype (Lit_Node, Choice_Type);
|
|
Set_Is_Static_Expression (Lit_Node);
|
|
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);
|
|
Set_Is_Static_Expression (Lo);
|
|
Hi := Make_Integer_Literal (Loc, Value2);
|
|
Set_Etype (Hi, Choice_Type);
|
|
Set_Is_Static_Expression (Hi);
|
|
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 :=
|
|
Make_Character_Literal (Loc,
|
|
Chars => Name_Find,
|
|
Char_Literal_Value => 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 Check_Case_Pattern_Choices;
|
|
-- Check choices validity for the Ada extension case where the
|
|
-- selecting expression is not of a discrete type and so the
|
|
-- choices are patterns.
|
|
|
|
procedure Check_Composite_Case_Selector;
|
|
-- Check that the (non-discrete) type of the expression being
|
|
-- cased on is suitable.
|
|
|
|
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;
|
|
|
|
--------------------------------
|
|
-- Check_Case_Pattern_Choices --
|
|
--------------------------------
|
|
|
|
procedure Check_Case_Pattern_Choices is
|
|
-- ??? Need to Free/Finalize value sets allocated here.
|
|
|
|
package Ops is new Composite_Case_Ops.Choice_Analysis
|
|
(Case_Statement => N);
|
|
use Ops;
|
|
use Ops.Value_Sets;
|
|
|
|
Empty : Value_Set renames Value_Sets.Empty;
|
|
-- Cope with hiding due to multiple use clauses
|
|
|
|
Info : constant Choices_Info := Analysis;
|
|
Others_Seen : Boolean := False;
|
|
|
|
begin
|
|
declare
|
|
Matches : array (Alternative_Id) of Value_Sets.Value_Set :=
|
|
(others => Empty);
|
|
|
|
Flag_Overlapping_Within_One_Alternative : constant Boolean :=
|
|
False;
|
|
-- We may want to flag overlapping (perhaps with only a
|
|
-- warning) if the pattern binds an identifier, as in
|
|
-- when (Positive, <X>) | (Integer, <X>) =>
|
|
|
|
Covered : Value_Set := Empty;
|
|
-- The union of all alternatives seen so far
|
|
|
|
begin
|
|
for Choice of Info loop
|
|
if Choice.Is_Others then
|
|
Others_Seen := True;
|
|
else
|
|
if Flag_Overlapping_Within_One_Alternative
|
|
and then (Compare (Matches (Choice.Alternative),
|
|
Choice.Matches) /= Disjoint)
|
|
then
|
|
Error_Msg_N
|
|
("bad overlapping within one alternative", N);
|
|
end if;
|
|
|
|
Union (Target => Matches (Choice.Alternative),
|
|
Source => Choice.Matches);
|
|
end if;
|
|
end loop;
|
|
|
|
for A1 in Alternative_Id loop
|
|
for A2 in Alternative_Id
|
|
range A1 + 1 .. Alternative_Id'Last
|
|
loop
|
|
case Compare (Matches (A1), Matches (A2)) is
|
|
when Disjoint | Contained_By =>
|
|
null; -- OK
|
|
when Overlaps =>
|
|
declare
|
|
Uncovered_1, Uncovered_2 : Value_Set := Empty;
|
|
begin
|
|
Union (Uncovered_1, Matches (A1));
|
|
Remove (Uncovered_1, Covered);
|
|
Union (Uncovered_2, Matches (A2));
|
|
Remove (Uncovered_2, Covered);
|
|
|
|
-- Recheck for overlap after removing choices
|
|
-- covered by earlier alternatives.
|
|
|
|
case Compare (Uncovered_1, Uncovered_2) is
|
|
when Disjoint | Contained_By =>
|
|
null;
|
|
when Contains | Overlaps | Equal =>
|
|
Error_Msg_N
|
|
("bad alternative overlapping", N);
|
|
end case;
|
|
end;
|
|
|
|
when Equal =>
|
|
Error_Msg_N ("alternatives match same values", N);
|
|
when Contains =>
|
|
Error_Msg_N ("alternatives in wrong order", N);
|
|
end case;
|
|
end loop;
|
|
|
|
Union (Target => Covered, Source => Matches (A1));
|
|
end loop;
|
|
|
|
if (not Others_Seen) and then not Complement_Is_Empty (Covered)
|
|
then
|
|
Error_Msg_N ("not all values are covered", N);
|
|
end if;
|
|
end;
|
|
|
|
Ops.Value_Sets.Free_Value_Sets;
|
|
end Check_Case_Pattern_Choices;
|
|
|
|
-----------------------------------
|
|
-- Check_Composite_Case_Selector --
|
|
-----------------------------------
|
|
|
|
procedure Check_Composite_Case_Selector is
|
|
begin
|
|
if not Is_Composite_Type (Subtyp) then
|
|
Error_Msg_N
|
|
("case selector type must be discrete or composite", N);
|
|
elsif Is_Limited_Type (Subtyp) then
|
|
Error_Msg_N ("case selector type must not be limited", N);
|
|
elsif Is_Class_Wide_Type (Subtyp) then
|
|
Error_Msg_N ("case selector type must not be class-wide", N);
|
|
elsif Needs_Finalization (Subtyp)
|
|
and then Is_Newly_Constructed
|
|
(Expression (N), Context_Requires_NC => False)
|
|
then
|
|
-- We could allow this case as long as there are no bindings.
|
|
--
|
|
-- If there are bindings, then allowing this case will get
|
|
-- messy because the selector expression will be finalized
|
|
-- before the statements of the selected alternative are
|
|
-- executed (unless we add an INOX-specific change to the
|
|
-- accessibility rules to prevent this earlier-than-wanted
|
|
-- finalization, but adding new INOX-specific accessibility
|
|
-- complexity is probably not the direction we want to go).
|
|
-- This early selector finalization would be ok if we made
|
|
-- copies in this case (so that the bindings would not yield
|
|
-- a view of a finalized object), but then we'd have to deal
|
|
-- with finalizing those copies (which would necessarily
|
|
-- include defining their accessibility level). So it gets
|
|
-- messy either way.
|
|
|
|
Error_Msg_N ("case selector must not require finalization", N);
|
|
end if;
|
|
end Check_Composite_Case_Selector;
|
|
|
|
-----------------------------
|
|
-- 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));
|
|
Set_Original_Node (C, 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
|
|
|
|
-- Hold on, maybe it isn't a complete mess after all.
|
|
|
|
if Extensions_Allowed and then Subtyp /= Any_Type then
|
|
Check_Composite_Case_Selector;
|
|
Check_Case_Pattern_Choices;
|
|
end if;
|
|
|
|
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 nonstatic 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 nonstatic.
|
|
|
|
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 nonstatic 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;
|
|
|
|
-----------------------------------------
|
|
-- Has_Static_Discriminant_Constraint --
|
|
-----------------------------------------
|
|
|
|
function Has_Static_Discriminant_Constraint
|
|
(Subtyp : Entity_Id) return Boolean
|
|
is
|
|
begin
|
|
if Has_Discriminants (Subtyp) and then Is_Constrained (Subtyp) then
|
|
declare
|
|
DC_Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Subtyp));
|
|
begin
|
|
while Present (DC_Elmt) loop
|
|
if not All_Composite_Constraints_Static (Node (DC_Elmt)) then
|
|
return False;
|
|
end if;
|
|
Next_Elmt (DC_Elmt);
|
|
end loop;
|
|
return True;
|
|
end;
|
|
end if;
|
|
return False;
|
|
end Has_Static_Discriminant_Constraint;
|
|
|
|
----------------------------
|
|
-- Is_Case_Choice_Pattern --
|
|
----------------------------
|
|
|
|
function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is
|
|
E : Node_Id := Expr;
|
|
begin
|
|
if not Extensions_Allowed then
|
|
return False;
|
|
end if;
|
|
|
|
loop
|
|
case Nkind (E) is
|
|
when N_Case_Statement_Alternative
|
|
| N_Case_Expression_Alternative
|
|
=>
|
|
-- We could return False if selecting expression is discrete,
|
|
-- but this doesn't seem to be worth the bother.
|
|
return True;
|
|
|
|
when N_Empty
|
|
| N_Statement_Other_Than_Procedure_Call
|
|
| N_Procedure_Call_Statement
|
|
| N_Declaration
|
|
=>
|
|
return False;
|
|
|
|
when others =>
|
|
E := Parent (E);
|
|
end case;
|
|
end loop;
|
|
end Is_Case_Choice_Pattern;
|
|
|
|
end Sem_Case;
|