------------------------------------------------------------------------------ -- -- -- 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 => " 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 := ; -- 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 (, 0) | (0, ) => -- 2) A choice shall not define a name twice. Can't have -- when (A => , B => , 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 (, 1) | (1, ) => -- 4) A given binding shall match only one value. -- Can't have -- (Fld1 | Fld2 => (Fld => )) -- 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, ) | (Integer, ) => 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;