| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C A S E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Einfo; use Einfo; |
| with Errout; use Errout; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sem_Type; use Sem_Type; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Sinfo; use Sinfo; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| with Ada.Unchecked_Deallocation; |
| |
| with GNAT.Heap_Sort_G; |
| |
| package body Sem_Case is |
| |
| type Choice_Bounds is record |
| Lo : Node_Id; |
| Hi : Node_Id; |
| Node : Node_Id; |
| end record; |
| -- Represent one choice bounds entry with Lo and Hi values, Node points |
| -- to the choice node itself. |
| |
| type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; |
| -- Table type used to sort the choices present in a case statement or |
| -- record variant. The actual entries are stored in 1 .. Last, but we |
| -- have a 0 entry for use in sorting. |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Check_Choice_Set |
| (Choice_Table : in out Choice_Table_Type; |
| Bounds_Type : Entity_Id; |
| Subtyp : Entity_Id; |
| Others_Present : Boolean; |
| Case_Node : Node_Id); |
| -- This is the procedure which verifies that a set of case alternatives |
| -- or record variant choices has no duplicates, and covers the range |
| -- specified by Bounds_Type. Choice_Table contains the discrete choices |
| -- to check. These must start at position 1. |
| -- |
| -- Furthermore Choice_Table (0) must exist. This element is used by |
| -- the sorting algorithm as a temporary. Others_Present is a flag |
| -- indicating whether or not an Others choice is present. Finally |
| -- Msg_Sloc gives the source location of the construct containing the |
| -- choices in the Choice_Table. |
| -- |
| -- Bounds_Type is the type whose range must be covered by the alternatives |
| -- |
| -- Subtyp is the subtype of the expression. If its bounds are non-static |
| -- the alternatives must cover its base type. |
| |
| function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; |
| -- Given a Pos value of enumeration type Ctype, returns the name |
| -- ID of an appropriate string to be used in error message output. |
| |
| procedure Expand_Others_Choice |
| (Case_Table : Choice_Table_Type; |
| Others_Choice : Node_Id; |
| Choice_Type : Entity_Id); |
| -- The case table is the table generated by a call to Check_Choices |
| -- (with just 1 .. Last_Choice entries present). Others_Choice is a |
| -- pointer to the N_Others_Choice node (this routine is only called if |
| -- an others choice is present), and Choice_Type is the discrete type |
| -- of the bounds. The effect of this call is to analyze the cases and |
| -- determine the set of values covered by others. This choice list is |
| -- set in the Others_Discrete_Choices field of the N_Others_Choice node. |
| |
| ---------------------- |
| -- Check_Choice_Set -- |
| ---------------------- |
| |
| procedure Check_Choice_Set |
| (Choice_Table : in out Choice_Table_Type; |
| Bounds_Type : Entity_Id; |
| Subtyp : Entity_Id; |
| Others_Present : Boolean; |
| Case_Node : Node_Id) |
| is |
| Predicate_Error : Boolean; |
| -- Flag to prevent cascaded errors when a static predicate is known to |
| -- be violated by one choice. |
| |
| procedure Check_Against_Predicate |
| (Pred : in out Node_Id; |
| Choice : Choice_Bounds; |
| Prev_Lo : in out Uint; |
| Prev_Hi : in out Uint; |
| Error : in out Boolean); |
| -- Determine whether a choice covers legal values as defined by a static |
| -- predicate set. Pred is a static predicate range. Choice is the choice |
| -- to be examined. Prev_Lo and Prev_Hi are the bounds of the previous |
| -- choice that covered a predicate set. Error denotes whether the check |
| -- found an illegal intersection. |
| |
| procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); |
| -- Post message "duplication of choice value(s) bla bla at xx". Message |
| -- is posted at location C. Caller sets Error_Msg_Sloc for xx. |
| |
| procedure Explain_Non_Static_Bound; |
| -- Called when we find a non-static bound, requiring the base type to |
| -- be covered. Provides where possible a helpful explanation of why the |
| -- bounds are non-static, since this is not always obvious. |
| |
| function Lt_Choice (C1, C2 : Natural) return Boolean; |
| -- Comparison routine for comparing Choice_Table entries. Use the lower |
| -- bound of each Choice as the key. |
| |
| procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id); |
| procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint); |
| procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id); |
| procedure Missing_Choice (Value1 : Uint; Value2 : Uint); |
| -- Issue an error message indicating that there are missing choices, |
| -- followed by the image of the missing choices themselves which lie |
| -- between Value1 and Value2 inclusive. |
| |
| procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint); |
| -- Emit an error message for each non-covered static predicate set. |
| -- Prev_Hi denotes the upper bound of the last choice covering a set. |
| |
| procedure Move_Choice (From : Natural; To : Natural); |
| -- Move routine for sorting the Choice_Table |
| |
| package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice); |
| |
| ----------------------------- |
| -- Check_Against_Predicate -- |
| ----------------------------- |
| |
| procedure Check_Against_Predicate |
| (Pred : in out Node_Id; |
| Choice : Choice_Bounds; |
| Prev_Lo : in out Uint; |
| Prev_Hi : in out Uint; |
| Error : in out Boolean) |
| is |
| procedure Illegal_Range |
| (Loc : Source_Ptr; |
| Lo : Uint; |
| Hi : Uint); |
| -- Emit an error message regarding a choice that clashes with the |
| -- legal static predicate sets. Loc is the location of the choice |
| -- that introduced the illegal range. Lo .. Hi is the range. |
| |
| function Inside_Range |
| (Lo : Uint; |
| Hi : Uint; |
| Val : Uint) return Boolean; |
| -- Determine whether position Val within a discrete type is within |
| -- the range Lo .. Hi inclusive. |
| |
| ------------------- |
| -- Illegal_Range -- |
| ------------------- |
| |
| procedure Illegal_Range |
| (Loc : Source_Ptr; |
| Lo : Uint; |
| Hi : Uint) |
| is |
| begin |
| Error_Msg_Name_1 := Chars (Bounds_Type); |
| |
| -- Single value |
| |
| if Lo = Hi then |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Lo; |
| Error_Msg ("static predicate on % excludes value ^!", Loc); |
| else |
| Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); |
| Error_Msg ("static predicate on % excludes value %!", Loc); |
| end if; |
| |
| -- Range |
| |
| else |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Lo; |
| Error_Msg_Uint_2 := Hi; |
| Error_Msg |
| ("static predicate on % excludes range ^ .. ^!", Loc); |
| else |
| Error_Msg_Name_2 := Choice_Image (Lo, Bounds_Type); |
| Error_Msg_Name_3 := Choice_Image (Hi, Bounds_Type); |
| Error_Msg |
| ("static predicate on % excludes range % .. %!", Loc); |
| end if; |
| end if; |
| end Illegal_Range; |
| |
| ------------------ |
| -- Inside_Range -- |
| ------------------ |
| |
| function Inside_Range |
| (Lo : Uint; |
| Hi : Uint; |
| Val : Uint) return Boolean |
| is |
| begin |
| return |
| Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi); |
| end Inside_Range; |
| |
| -- Local variables |
| |
| Choice_Hi : constant Uint := Expr_Value (Choice.Hi); |
| Choice_Lo : constant Uint := Expr_Value (Choice.Lo); |
| Loc : Source_Ptr; |
| LocN : Node_Id; |
| Next_Hi : Uint; |
| Next_Lo : Uint; |
| Pred_Hi : Uint; |
| Pred_Lo : Uint; |
| |
| -- Start of processing for Check_Against_Predicate |
| |
| begin |
| -- Find the proper error message location |
| |
| if Present (Choice.Node) then |
| LocN := Choice.Node; |
| else |
| LocN := Case_Node; |
| end if; |
| |
| Loc := Sloc (LocN); |
| |
| if Present (Pred) then |
| Pred_Lo := Expr_Value (Low_Bound (Pred)); |
| Pred_Hi := Expr_Value (High_Bound (Pred)); |
| |
| -- Previous choices managed to satisfy all static predicate sets |
| |
| else |
| Illegal_Range (Loc, Choice_Lo, Choice_Hi); |
| Error := True; |
| return; |
| end if; |
| |
| -- Step 1: Detect duplicate choices |
| |
| if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then |
| Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN); |
| Error := True; |
| |
| elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then |
| Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN); |
| Error := True; |
| |
| -- Step 2: Detect full coverage |
| |
| -- Choice_Lo Choice_Hi |
| -- +============+ |
| -- Pred_Lo Pred_Hi |
| |
| elsif Choice_Lo = Pred_Lo and then Choice_Hi = Pred_Hi then |
| Prev_Lo := Choice_Lo; |
| Prev_Hi := Choice_Hi; |
| Next (Pred); |
| |
| -- Step 3: Detect all cases where a choice mentions values that are |
| -- not part of the static predicate sets. |
| |
| -- Choice_Lo Choice_Hi Pred_Lo Pred_Hi |
| -- +-----------+ . . . . . +=========+ |
| -- ^ illegal ^ |
| |
| elsif Choice_Lo < Pred_Lo and then Choice_Hi < Pred_Lo then |
| Illegal_Range (Loc, Choice_Lo, Choice_Hi); |
| Error := True; |
| |
| -- Choice_Lo Pred_Lo Choice_Hi Pred_Hi |
| -- +-----------+=========+===========+ |
| -- ^ illegal ^ |
| |
| elsif Choice_Lo < Pred_Lo |
| and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Hi) |
| then |
| Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); |
| Error := True; |
| |
| -- Pred_Lo Pred_Hi Choice_Lo Choice_Hi |
| -- +=========+ . . . . +-----------+ |
| -- ^ illegal ^ |
| |
| elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then |
| if Others_Present then |
| |
| -- Current predicate set is covered by others clause. |
| |
| null; |
| |
| else |
| Missing_Choice (Pred_Lo, Pred_Hi); |
| Error := True; |
| end if; |
| |
| -- There may be several static predicate sets between the current |
| -- one and the choice. Inspect the next static predicate set. |
| |
| Next (Pred); |
| Check_Against_Predicate |
| (Pred => Pred, |
| Choice => Choice, |
| Prev_Lo => Prev_Lo, |
| Prev_Hi => Prev_Hi, |
| Error => Error); |
| |
| -- Pred_Lo Choice_Lo Pred_Hi Choice_Hi |
| -- +=========+===========+-----------+ |
| -- ^ illegal ^ |
| |
| elsif Pred_Hi < Choice_Hi |
| and then Inside_Range (Pred_Lo, Pred_Hi, Choice_Lo) |
| then |
| Next (Pred); |
| |
| -- The choice may fall in a static predicate set. If this is the |
| -- case, avoid mentioning legal values in the error message. |
| |
| if Present (Pred) then |
| Next_Lo := Expr_Value (Low_Bound (Pred)); |
| Next_Hi := Expr_Value (High_Bound (Pred)); |
| |
| -- The next static predicate set is to the right of the choice |
| |
| if Choice_Hi < Next_Lo and then Choice_Hi < Next_Hi then |
| Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); |
| else |
| Illegal_Range (Loc, Pred_Hi + 1, Next_Lo - 1); |
| end if; |
| else |
| Illegal_Range (Loc, Pred_Hi + 1, Choice_Hi); |
| end if; |
| |
| Error := True; |
| |
| -- Choice_Lo Pred_Lo Pred_Hi Choice_Hi |
| -- +-----------+=========+-----------+ |
| -- ^ illegal ^ ^ illegal ^ |
| |
| -- Emit an error on the low gap, disregard the upper gap |
| |
| elsif Choice_Lo < Pred_Lo and then Pred_Hi < Choice_Hi then |
| Illegal_Range (Loc, Choice_Lo, Pred_Lo - 1); |
| Error := True; |
| |
| -- Step 4: Detect all cases of partial or missing coverage |
| |
| -- Pred_Lo Choice_Lo Choice_Hi Pred_Hi |
| -- +=========+==========+===========+ |
| -- ^ gap ^ ^ gap ^ |
| |
| else |
| -- An "others" choice covers all gaps |
| |
| if Others_Present then |
| Prev_Lo := Choice_Lo; |
| Prev_Hi := Choice_Hi; |
| |
| -- Check whether predicate set is fully covered by choice |
| |
| if Pred_Hi = Choice_Hi then |
| Next (Pred); |
| end if; |
| |
| -- Choice_Lo Choice_Hi Pred_Hi |
| -- +===========+===========+ |
| -- Pred_Lo ^ gap ^ |
| |
| -- The upper gap may be covered by a subsequent choice |
| |
| elsif Pred_Lo = Choice_Lo then |
| Prev_Lo := Choice_Lo; |
| Prev_Hi := Choice_Hi; |
| |
| -- Pred_Lo Prev_Hi Choice_Lo Choice_Hi Pred_Hi |
| -- +===========+=========+===========+===========+ |
| -- ^ covered ^ ^ gap ^ |
| |
| else pragma Assert (Pred_Lo < Choice_Lo); |
| |
| -- A previous choice covered the gap up to the current choice |
| |
| if Prev_Hi = Choice_Lo - 1 then |
| Prev_Lo := Choice_Lo; |
| Prev_Hi := Choice_Hi; |
| |
| if Choice_Hi = Pred_Hi then |
| Next (Pred); |
| end if; |
| |
| -- The previous choice did not intersect with the current |
| -- static predicate set. |
| |
| elsif Prev_Hi < Pred_Lo then |
| Missing_Choice (Pred_Lo, Choice_Lo - 1); |
| Error := True; |
| |
| -- The previous choice covered part of the static predicate set |
| -- but there is a gap after Prev_Hi. |
| |
| else |
| Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); |
| Error := True; |
| end if; |
| end if; |
| end if; |
| end Check_Against_Predicate; |
| |
| ---------------- |
| -- Dup_Choice -- |
| ---------------- |
| |
| procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is |
| begin |
| -- In some situations, we call this with a null range, and obviously |
| -- we don't want to complain in this case. |
| |
| if Lo > Hi then |
| return; |
| end if; |
| |
| -- Case of only one value that is duplicated |
| |
| if Lo = Hi then |
| |
| -- Integer type |
| |
| if Is_Integer_Type (Bounds_Type) then |
| |
| -- We have an integer value, Lo, but if the given choice |
| -- placement is a constant with that value, then use the |
| -- name of that constant instead in the message: |
| |
| if Nkind (C) = N_Identifier |
| and then Compile_Time_Known_Value (C) |
| and then Expr_Value (C) = Lo |
| then |
| Error_Msg_N ("duplication of choice value: &#!", C); |
| |
| -- Not that special case, so just output the integer value |
| |
| else |
| Error_Msg_Uint_1 := Lo; |
| Error_Msg_N ("duplication of choice value: ^#!", C); |
| end if; |
| |
| -- Enumeration type |
| |
| else |
| Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); |
| Error_Msg_N ("duplication of choice value: %#!", C); |
| end if; |
| |
| -- More than one choice value, so print range of values |
| |
| else |
| -- Integer type |
| |
| if Is_Integer_Type (Bounds_Type) then |
| |
| -- Similar to the above, if C is a range of known values which |
| -- match Lo and Hi, then use the names. We have to go to the |
| -- original nodes, since the values will have been rewritten |
| -- to their integer values. |
| |
| if Nkind (C) = N_Range |
| and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier |
| and then Nkind (Original_Node (High_Bound (C))) = N_Identifier |
| and then Compile_Time_Known_Value (Low_Bound (C)) |
| and then Compile_Time_Known_Value (High_Bound (C)) |
| and then Expr_Value (Low_Bound (C)) = Lo |
| and then Expr_Value (High_Bound (C)) = Hi |
| then |
| Error_Msg_Node_2 := Original_Node (High_Bound (C)); |
| Error_Msg_N |
| ("duplication of choice values: & .. &#!", |
| Original_Node (Low_Bound (C))); |
| |
| -- Not that special case, output integer values |
| |
| else |
| Error_Msg_Uint_1 := Lo; |
| Error_Msg_Uint_2 := Hi; |
| Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); |
| end if; |
| |
| -- Enumeration type |
| |
| else |
| Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); |
| Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); |
| Error_Msg_N ("duplication of choice values: % .. %#!", C); |
| end if; |
| end if; |
| end Dup_Choice; |
| |
| ------------------------------ |
| -- Explain_Non_Static_Bound -- |
| ------------------------------ |
| |
| procedure Explain_Non_Static_Bound is |
| Expr : Node_Id; |
| |
| begin |
| if Nkind (Case_Node) = N_Variant_Part then |
| Expr := Name (Case_Node); |
| else |
| Expr := Expression (Case_Node); |
| end if; |
| |
| if Bounds_Type /= Subtyp then |
| |
| -- If the case is a variant part, the expression is given by the |
| -- discriminant itself, and the bounds are the culprits. |
| |
| if Nkind (Case_Node) = N_Variant_Part then |
| Error_Msg_NE |
| ("bounds of & are not static, " |
| & "alternatives must cover base type!", Expr, Expr); |
| |
| -- If this is a case statement, the expression may be non-static |
| -- or else the subtype may be at fault. |
| |
| elsif Is_Entity_Name (Expr) then |
| Error_Msg_NE |
| ("bounds of & are not static, " |
| & "alternatives must cover base type!", Expr, Expr); |
| |
| else |
| Error_Msg_N |
| ("subtype of expression is not static, " |
| & "alternatives must cover base type!", Expr); |
| end if; |
| |
| -- Otherwise the expression is not static, even if the bounds of the |
| -- type are, or else there are missing alternatives. If both, the |
| -- additional information may be redundant but harmless. |
| |
| elsif not Is_Entity_Name (Expr) then |
| Error_Msg_N |
| ("subtype of expression is not static, " |
| & "alternatives must cover base type!", Expr); |
| end if; |
| end Explain_Non_Static_Bound; |
| |
| --------------- |
| -- Lt_Choice -- |
| --------------- |
| |
| function Lt_Choice (C1, C2 : Natural) return Boolean is |
| begin |
| return |
| Expr_Value (Choice_Table (Nat (C1)).Lo) |
| < |
| Expr_Value (Choice_Table (Nat (C2)).Lo); |
| end Lt_Choice; |
| |
| -------------------- |
| -- Missing_Choice -- |
| -------------------- |
| |
| procedure Missing_Choice (Value1 : Node_Id; Value2 : Node_Id) is |
| begin |
| Missing_Choice (Expr_Value (Value1), Expr_Value (Value2)); |
| end Missing_Choice; |
| |
| procedure Missing_Choice (Value1 : Node_Id; Value2 : Uint) is |
| begin |
| Missing_Choice (Expr_Value (Value1), Value2); |
| end Missing_Choice; |
| |
| procedure Missing_Choice (Value1 : Uint; Value2 : Node_Id) is |
| begin |
| Missing_Choice (Value1, Expr_Value (Value2)); |
| end Missing_Choice; |
| |
| -------------------- |
| -- Missing_Choice -- |
| -------------------- |
| |
| procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is |
| Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); |
| |
| begin |
| -- AI05-0188 : within an instance the non-others choices do not have |
| -- to belong to the actual subtype. |
| |
| if Ada_Version >= Ada_2012 and then In_Instance then |
| return; |
| |
| -- In some situations, we call this with a null range, and obviously |
| -- we don't want to complain in this case. |
| |
| elsif Value1 > Value2 then |
| return; |
| |
| -- If predicate is already known to be violated, do no check for |
| -- coverage error, to prevent cascaded messages. |
| |
| elsif Predicate_Error then |
| return; |
| end if; |
| |
| -- Case of only one value that is missing |
| |
| if Value1 = Value2 then |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Value1; |
| Error_Msg ("missing case value: ^!", Msg_Sloc); |
| else |
| Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); |
| Error_Msg ("missing case value: %!", Msg_Sloc); |
| end if; |
| |
| -- More than one choice value, so print range of values |
| |
| else |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Value1; |
| Error_Msg_Uint_2 := Value2; |
| Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); |
| else |
| Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); |
| Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); |
| Error_Msg ("missing case values: % .. %!", Msg_Sloc); |
| end if; |
| end if; |
| end Missing_Choice; |
| |
| --------------------- |
| -- Missing_Choices -- |
| --------------------- |
| |
| procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint) is |
| Hi : Uint; |
| Lo : Uint; |
| Set : Node_Id; |
| |
| begin |
| Set := Pred; |
| while Present (Set) loop |
| Lo := Expr_Value (Low_Bound (Set)); |
| Hi := Expr_Value (High_Bound (Set)); |
| |
| -- A choice covered part of a static predicate set |
| |
| if Lo <= Prev_Hi and then Prev_Hi < Hi then |
| Missing_Choice (Prev_Hi + 1, Hi); |
| |
| else |
| Missing_Choice (Lo, Hi); |
| end if; |
| |
| Next (Set); |
| end loop; |
| end Missing_Choices; |
| |
| ----------------- |
| -- Move_Choice -- |
| ----------------- |
| |
| procedure Move_Choice (From : Natural; To : Natural) is |
| begin |
| Choice_Table (Nat (To)) := Choice_Table (Nat (From)); |
| end Move_Choice; |
| |
| -- Local variables |
| |
| Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); |
| Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); |
| Num_Choices : constant Nat := Choice_Table'Last; |
| Has_Predicate : constant Boolean := |
| Is_OK_Static_Subtype (Bounds_Type) |
| and then Has_Static_Predicate (Bounds_Type); |
| |
| Choice : Node_Id; |
| Choice_Hi : Uint; |
| Choice_Lo : Uint; |
| Error : Boolean; |
| Pred : Node_Id; |
| Prev_Choice : Node_Id; |
| Prev_Lo : Uint; |
| Prev_Hi : Uint; |
| |
| -- Start of processing for Check_Choice_Set |
| |
| begin |
| -- If the case is part of a predicate aspect specification, do not |
| -- recheck it against itself. |
| |
| if Present (Parent (Case_Node)) |
| and then Nkind (Parent (Case_Node)) = N_Aspect_Specification |
| then |
| return; |
| end if; |
| |
| Predicate_Error := False; |
| |
| -- Choice_Table must start at 0 which is an unused location used by the |
| -- sorting algorithm. However the first valid position for a discrete |
| -- choice is 1. |
| |
| pragma Assert (Choice_Table'First = 0); |
| |
| -- The choices do not cover the base range. Emit an error if "others" is |
| -- not available and return as there is no need for further processing. |
| |
| if Num_Choices = 0 then |
| if not Others_Present then |
| Missing_Choice (Bounds_Lo, Bounds_Hi); |
| end if; |
| |
| return; |
| end if; |
| |
| Sorting.Sort (Positive (Choice_Table'Last)); |
| |
| -- The type covered by the list of choices is actually a static subtype |
| -- subject to a static predicate. The predicate defines subsets of legal |
| -- values and requires finer grained analysis. |
| |
| -- Note that in GNAT the predicate is considered static if the predicate |
| -- expression is static, independently of whether the aspect mentions |
| -- Static explicitly. |
| |
| if Has_Predicate then |
| Pred := First (Static_Discrete_Predicate (Bounds_Type)); |
| Prev_Lo := Uint_Minus_1; |
| Prev_Hi := Uint_Minus_1; |
| Error := False; |
| |
| for Index in 1 .. Num_Choices loop |
| Check_Against_Predicate |
| (Pred => Pred, |
| Choice => Choice_Table (Index), |
| Prev_Lo => Prev_Lo, |
| Prev_Hi => Prev_Hi, |
| Error => Error); |
| |
| -- The analysis detected an illegal intersection between a choice |
| -- and a static predicate set. Do not examine other choices unless |
| -- all errors are requested. |
| |
| if Error then |
| Predicate_Error := True; |
| |
| if not All_Errors_Mode then |
| return; |
| end if; |
| end if; |
| end loop; |
| |
| if Predicate_Error then |
| return; |
| end if; |
| |
| -- The choices may legally cover some of the static predicate sets, |
| -- but not all. Emit an error for each non-covered set. |
| |
| if not Others_Present then |
| Missing_Choices (Pred, Prev_Hi); |
| end if; |
| |
| -- Default analysis |
| |
| else |
| Choice_Lo := Expr_Value (Choice_Table (1).Lo); |
| Choice_Hi := Expr_Value (Choice_Table (1).Hi); |
| Prev_Hi := Choice_Hi; |
| |
| if not Others_Present and then Expr_Value (Bounds_Lo) < Choice_Lo then |
| Missing_Choice (Bounds_Lo, Choice_Lo - 1); |
| |
| -- If values are missing outside of the subtype, add explanation. |
| -- No additional message if only one value is missing. |
| |
| if Expr_Value (Bounds_Lo) < Choice_Lo - 1 then |
| Explain_Non_Static_Bound; |
| end if; |
| end if; |
| |
| for Outer_Index in 2 .. Num_Choices loop |
| Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); |
| Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); |
| |
| if Choice_Lo <= Prev_Hi then |
| Choice := Choice_Table (Outer_Index).Node; |
| |
| -- Find first previous choice that overlaps |
| |
| for Inner_Index in 1 .. Outer_Index - 1 loop |
| if Choice_Lo <= |
| Expr_Value (Choice_Table (Inner_Index).Hi) |
| then |
| Prev_Choice := Choice_Table (Inner_Index).Node; |
| exit; |
| end if; |
| end loop; |
| |
| if Sloc (Prev_Choice) <= Sloc (Choice) then |
| Error_Msg_Sloc := Sloc (Prev_Choice); |
| Dup_Choice |
| (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); |
| else |
| Error_Msg_Sloc := Sloc (Choice); |
| Dup_Choice |
| (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); |
| end if; |
| |
| elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then |
| Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); |
| end if; |
| |
| if Choice_Hi > Prev_Hi then |
| Prev_Hi := Choice_Hi; |
| end if; |
| end loop; |
| |
| if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then |
| Missing_Choice (Prev_Hi + 1, Bounds_Hi); |
| |
| if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then |
| Explain_Non_Static_Bound; |
| end if; |
| end if; |
| end if; |
| end Check_Choice_Set; |
| |
| ------------------ |
| -- Choice_Image -- |
| ------------------ |
| |
| function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is |
| Rtp : constant Entity_Id := Root_Type (Ctype); |
| Lit : Entity_Id; |
| C : Int; |
| |
| begin |
| -- For character, or wide [wide] character. If 7-bit ASCII graphic |
| -- range, then build and return appropriate character literal name |
| |
| if Is_Standard_Character_Type (Ctype) then |
| C := UI_To_Int (Value); |
| |
| if C in 16#20# .. 16#7E# then |
| Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); |
| return Name_Find; |
| end if; |
| |
| -- For user defined enumeration type, find enum/char literal |
| |
| else |
| Lit := First_Literal (Rtp); |
| |
| for J in 1 .. UI_To_Int (Value) loop |
| Next_Literal (Lit); |
| end loop; |
| |
| -- If enumeration literal, just return its value |
| |
| if Nkind (Lit) = N_Defining_Identifier then |
| return Chars (Lit); |
| |
| -- For character literal, get the name and use it if it is |
| -- for a 7-bit ASCII graphic character in 16#20#..16#7E#. |
| |
| else |
| Get_Decoded_Name_String (Chars (Lit)); |
| |
| if Name_Len = 3 |
| and then Name_Buffer (2) in |
| Character'Val (16#20#) .. Character'Val (16#7E#) |
| then |
| return Chars (Lit); |
| end if; |
| end if; |
| end if; |
| |
| -- If we fall through, we have a character literal which is not in |
| -- the 7-bit ASCII graphic set. For such cases, we construct the |
| -- name "type'val(nnn)" where type is the choice type, and nnn is |
| -- the pos value passed as an argument to Choice_Image. |
| |
| Get_Name_String (Chars (First_Subtype (Ctype))); |
| |
| Add_Str_To_Name_Buffer ("'val("); |
| UI_Image (Value); |
| Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length)); |
| Add_Char_To_Name_Buffer (')'); |
| return Name_Find; |
| end Choice_Image; |
| |
| -------------------------- |
| -- Expand_Others_Choice -- |
| -------------------------- |
| |
| procedure Expand_Others_Choice |
| (Case_Table : Choice_Table_Type; |
| Others_Choice : Node_Id; |
| Choice_Type : Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (Others_Choice); |
| Choice_List : constant List_Id := New_List; |
| Choice : Node_Id; |
| Exp_Lo : Node_Id; |
| Exp_Hi : Node_Id; |
| Hi : Uint; |
| Lo : Uint; |
| Previous_Hi : Uint; |
| |
| function Build_Choice (Value1, Value2 : Uint) return Node_Id; |
| -- Builds a node representing the missing choices given by Value1 and |
| -- Value2. A N_Range node is built if there is more than one literal |
| -- value missing. Otherwise a single N_Integer_Literal, N_Identifier |
| -- or N_Character_Literal is built depending on what Choice_Type is. |
| |
| function Lit_Of (Value : Uint) return Node_Id; |
| -- Returns the Node_Id for the enumeration literal corresponding to the |
| -- position given by Value within the enumeration type Choice_Type. |
| |
| ------------------ |
| -- Build_Choice -- |
| ------------------ |
| |
| function Build_Choice (Value1, Value2 : Uint) return Node_Id is |
| Lit_Node : Node_Id; |
| Lo, Hi : Node_Id; |
| |
| begin |
| -- If there is only one choice value missing between Value1 and |
| -- Value2, build an integer or enumeration literal to represent it. |
| |
| if (Value2 - Value1) = 0 then |
| if Is_Integer_Type (Choice_Type) then |
| Lit_Node := Make_Integer_Literal (Loc, Value1); |
| Set_Etype (Lit_Node, Choice_Type); |
| else |
| Lit_Node := Lit_Of (Value1); |
| end if; |
| |
| -- Otherwise is more that one choice value that is missing between |
| -- Value1 and Value2, therefore build a N_Range node of either |
| -- integer or enumeration literals. |
| |
| else |
| if Is_Integer_Type (Choice_Type) then |
| Lo := Make_Integer_Literal (Loc, Value1); |
| Set_Etype (Lo, Choice_Type); |
| Hi := Make_Integer_Literal (Loc, Value2); |
| Set_Etype (Hi, Choice_Type); |
| Lit_Node := |
| Make_Range (Loc, |
| Low_Bound => Lo, |
| High_Bound => Hi); |
| |
| else |
| Lit_Node := |
| Make_Range (Loc, |
| Low_Bound => Lit_Of (Value1), |
| High_Bound => Lit_Of (Value2)); |
| end if; |
| end if; |
| |
| return Lit_Node; |
| end Build_Choice; |
| |
| ------------ |
| -- Lit_Of -- |
| ------------ |
| |
| function Lit_Of (Value : Uint) return Node_Id is |
| Lit : Entity_Id; |
| |
| begin |
| -- In the case where the literal is of type Character, there needs |
| -- to be some special handling since there is no explicit chain |
| -- of literals to search. Instead, a N_Character_Literal node |
| -- is created with the appropriate Char_Code and Chars fields. |
| |
| if Is_Standard_Character_Type (Choice_Type) then |
| Set_Character_Literal_Name (Char_Code (UI_To_Int (Value))); |
| Lit := New_Node (N_Character_Literal, Loc); |
| Set_Chars (Lit, Name_Find); |
| Set_Char_Literal_Value (Lit, Value); |
| Set_Etype (Lit, Choice_Type); |
| Set_Is_Static_Expression (Lit, True); |
| return Lit; |
| |
| -- Otherwise, iterate through the literals list of Choice_Type |
| -- "Value" number of times until the desired literal is reached |
| -- and then return an occurrence of it. |
| |
| else |
| Lit := First_Literal (Choice_Type); |
| for J in 1 .. UI_To_Int (Value) loop |
| Next_Literal (Lit); |
| end loop; |
| |
| return New_Occurrence_Of (Lit, Loc); |
| end if; |
| end Lit_Of; |
| |
| -- Start of processing for Expand_Others_Choice |
| |
| begin |
| if Case_Table'Last = 0 then |
| |
| -- Special case: only an others case is present. The others case |
| -- covers the full range of the type. |
| |
| if Is_OK_Static_Subtype (Choice_Type) then |
| Choice := New_Occurrence_Of (Choice_Type, Loc); |
| else |
| Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); |
| end if; |
| |
| Set_Others_Discrete_Choices (Others_Choice, New_List (Choice)); |
| return; |
| end if; |
| |
| -- Establish the bound values for the choice depending upon whether the |
| -- type of the case statement is static or not. |
| |
| if Is_OK_Static_Subtype (Choice_Type) then |
| Exp_Lo := Type_Low_Bound (Choice_Type); |
| Exp_Hi := Type_High_Bound (Choice_Type); |
| else |
| Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); |
| Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); |
| end if; |
| |
| Lo := Expr_Value (Case_Table (1).Lo); |
| Hi := Expr_Value (Case_Table (1).Hi); |
| Previous_Hi := Expr_Value (Case_Table (1).Hi); |
| |
| -- Build the node for any missing choices that are smaller than any |
| -- explicit choices given in the case. |
| |
| if Expr_Value (Exp_Lo) < Lo then |
| Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List); |
| end if; |
| |
| -- Build the nodes representing any missing choices that lie between |
| -- the explicit ones given in the case. |
| |
| for J in 2 .. Case_Table'Last loop |
| Lo := Expr_Value (Case_Table (J).Lo); |
| Hi := Expr_Value (Case_Table (J).Hi); |
| |
| if Lo /= (Previous_Hi + 1) then |
| Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1)); |
| end if; |
| |
| Previous_Hi := Hi; |
| end loop; |
| |
| -- Build the node for any missing choices that are greater than any |
| -- explicit choices given in the case. |
| |
| if Expr_Value (Exp_Hi) > Hi then |
| Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List); |
| end if; |
| |
| Set_Others_Discrete_Choices (Others_Choice, Choice_List); |
| |
| -- Warn on null others list if warning option set |
| |
| if Warn_On_Redundant_Constructs |
| and then Comes_From_Source (Others_Choice) |
| and then Is_Empty_List (Choice_List) |
| then |
| Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice); |
| Error_Msg_N ("\?r?previous choices cover all values", Others_Choice); |
| end if; |
| end Expand_Others_Choice; |
| |
| ----------- |
| -- No_OP -- |
| ----------- |
| |
| procedure No_OP (C : Node_Id) is |
| pragma Warnings (Off, C); |
| begin |
| null; |
| end No_OP; |
| |
| ----------------------------- |
| -- Generic_Analyze_Choices -- |
| ----------------------------- |
| |
| package body Generic_Analyze_Choices is |
| |
| -- The following type is used to gather the entries for the choice |
| -- table, so that we can then allocate the right length. |
| |
| type Link; |
| type Link_Ptr is access all Link; |
| |
| type Link is record |
| Val : Choice_Bounds; |
| Nxt : Link_Ptr; |
| end record; |
| |
| --------------------- |
| -- Analyze_Choices -- |
| --------------------- |
| |
| procedure Analyze_Choices |
| (Alternatives : List_Id; |
| Subtyp : Entity_Id) |
| is |
| Choice_Type : constant Entity_Id := Base_Type (Subtyp); |
| -- The actual type against which the discrete choices are resolved. |
| -- Note that this type is always the base type not the subtype of the |
| -- ruling expression, index or discriminant. |
| |
| Expected_Type : Entity_Id; |
| -- The expected type of each choice. Equal to Choice_Type, except if |
| -- the expression is universal, in which case the choices can be of |
| -- any integer type. |
| |
| Alt : Node_Id; |
| -- A case statement alternative or a variant in a record type |
| -- declaration. |
| |
| Choice : Node_Id; |
| Kind : Node_Kind; |
| -- The node kind of the current Choice |
| |
| begin |
| -- Set Expected type (= choice type except for universal integer, |
| -- where we accept any integer type as a choice). |
| |
| if Choice_Type = Universal_Integer then |
| Expected_Type := Any_Integer; |
| else |
| Expected_Type := Choice_Type; |
| end if; |
| |
| -- Now loop through the case alternatives or record variants |
| |
| Alt := First (Alternatives); |
| while Present (Alt) loop |
| |
| -- If pragma, just analyze it |
| |
| if Nkind (Alt) = N_Pragma then |
| Analyze (Alt); |
| |
| -- Otherwise we have an alternative. In most cases the semantic |
| -- processing leaves the list of choices unchanged |
| |
| -- Check each choice against its base type |
| |
| else |
| Choice := First (Discrete_Choices (Alt)); |
| while Present (Choice) loop |
| Analyze (Choice); |
| Kind := Nkind (Choice); |
| |
| -- Choice is a Range |
| |
| if Kind = N_Range |
| or else (Kind = N_Attribute_Reference |
| and then Attribute_Name (Choice) = Name_Range) |
| then |
| Resolve (Choice, Expected_Type); |
| |
| -- Choice is a subtype name, nothing further to do now |
| |
| elsif Is_Entity_Name (Choice) |
| and then Is_Type (Entity (Choice)) |
| then |
| null; |
| |
| -- Choice is a subtype indication |
| |
| elsif Kind = N_Subtype_Indication then |
| Resolve_Discrete_Subtype_Indication |
| (Choice, Expected_Type); |
| |
| -- Others choice, no analysis needed |
| |
| elsif Kind = N_Others_Choice then |
| null; |
| |
| -- Only other possibility is an expression |
| |
| else |
| Resolve (Choice, Expected_Type); |
| end if; |
| |
| -- Move to next choice |
| |
| Next (Choice); |
| end loop; |
| |
| Process_Associated_Node (Alt); |
| end if; |
| |
| Next (Alt); |
| end loop; |
| end Analyze_Choices; |
| |
| end Generic_Analyze_Choices; |
| |
| --------------------------- |
| -- Generic_Check_Choices -- |
| --------------------------- |
| |
| package body Generic_Check_Choices is |
| |
| -- The following type is used to gather the entries for the choice |
| -- table, so that we can then allocate the right length. |
| |
| type Link; |
| type Link_Ptr is access all Link; |
| |
| type Link is record |
| Val : Choice_Bounds; |
| Nxt : Link_Ptr; |
| end record; |
| |
| procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); |
| |
| ------------------- |
| -- Check_Choices -- |
| ------------------- |
| |
| procedure Check_Choices |
| (N : Node_Id; |
| Alternatives : List_Id; |
| Subtyp : Entity_Id; |
| Others_Present : out Boolean) |
| is |
| E : Entity_Id; |
| |
| Raises_CE : Boolean; |
| -- Set True if one of the bounds of a choice raises CE |
| |
| Enode : Node_Id; |
| -- This is where we post error messages for bounds out of range |
| |
| Choice_List : Link_Ptr := null; |
| -- Gather list of choices |
| |
| Num_Choices : Nat := 0; |
| -- Number of entries in Choice_List |
| |
| Choice_Type : constant Entity_Id := Base_Type (Subtyp); |
| -- The actual type against which the discrete choices are resolved. |
| -- Note that this type is always the base type not the subtype of the |
| -- ruling expression, index or discriminant. |
| |
| Bounds_Type : Entity_Id; |
| -- The type from which are derived the bounds of the values covered |
| -- by the discrete choices (see 3.8.1 (4)). If a discrete choice |
| -- specifies a value outside of these bounds we have an error. |
| |
| Bounds_Lo : Uint; |
| Bounds_Hi : Uint; |
| -- The actual bounds of the above type |
| |
| Expected_Type : Entity_Id; |
| -- The expected type of each choice. Equal to Choice_Type, except if |
| -- the expression is universal, in which case the choices can be of |
| -- any integer type. |
| |
| Alt : Node_Id; |
| -- A case statement alternative or a variant in a record type |
| -- declaration. |
| |
| Choice : Node_Id; |
| Kind : Node_Kind; |
| -- The node kind of the current Choice |
| |
| Others_Choice : Node_Id := Empty; |
| -- Remember others choice if it is present (empty otherwise) |
| |
| procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); |
| -- Checks the validity of the bounds of a choice. When the bounds |
| -- are static and no error occurred the bounds are collected for |
| -- later entry into the choices table so that they can be sorted |
| -- later on. |
| |
| ----------- |
| -- Check -- |
| ----------- |
| |
| procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is |
| Lo_Val : Uint; |
| Hi_Val : Uint; |
| |
| begin |
| -- First check if an error was already detected on either bounds |
| |
| if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then |
| return; |
| |
| -- Do not insert non static choices in the table to be sorted |
| |
| elsif not Is_OK_Static_Expression (Lo) |
| or else |
| not Is_OK_Static_Expression (Hi) |
| then |
| Process_Non_Static_Choice (Choice); |
| return; |
| |
| -- Ignore range which raise constraint error |
| |
| elsif Raises_Constraint_Error (Lo) |
| or else Raises_Constraint_Error (Hi) |
| then |
| Raises_CE := True; |
| return; |
| |
| -- AI05-0188 : Within an instance the non-others choices do not |
| -- have to belong to the actual subtype. |
| |
| elsif Ada_Version >= Ada_2012 and then In_Instance then |
| return; |
| |
| -- Otherwise we have an OK static choice |
| |
| else |
| Lo_Val := Expr_Value (Lo); |
| Hi_Val := Expr_Value (Hi); |
| |
| -- Do not insert null ranges in the choices table |
| |
| if Lo_Val > Hi_Val then |
| Process_Empty_Choice (Choice); |
| return; |
| end if; |
| end if; |
| |
| -- Check for low bound out of range |
| |
| if Lo_Val < Bounds_Lo then |
| |
| -- If the choice is an entity name, then it is a type, and we |
| -- want to post the message on the reference to this entity. |
| -- Otherwise post it on the lower bound of the range. |
| |
| if Is_Entity_Name (Choice) then |
| Enode := Choice; |
| else |
| Enode := Lo; |
| end if; |
| |
| -- Specialize message for integer/enum type |
| |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Bounds_Lo; |
| Error_Msg_N ("minimum allowed choice value is^", Enode); |
| else |
| Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); |
| Error_Msg_N ("minimum allowed choice value is%", Enode); |
| end if; |
| end if; |
| |
| -- Check for high bound out of range |
| |
| if Hi_Val > Bounds_Hi then |
| |
| -- If the choice is an entity name, then it is a type, and we |
| -- want to post the message on the reference to this entity. |
| -- Otherwise post it on the upper bound of the range. |
| |
| if Is_Entity_Name (Choice) then |
| Enode := Choice; |
| else |
| Enode := Hi; |
| end if; |
| |
| -- Specialize message for integer/enum type |
| |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Bounds_Hi; |
| Error_Msg_N ("maximum allowed choice value is^", Enode); |
| else |
| Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); |
| Error_Msg_N ("maximum allowed choice value is%", Enode); |
| end if; |
| end if; |
| |
| -- Collect bounds in the list |
| |
| -- Note: we still store the bounds, even if they are out of range, |
| -- since this may prevent unnecessary cascaded errors for values |
| -- that are covered by such an excessive range. |
| |
| Choice_List := |
| new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); |
| Num_Choices := Num_Choices + 1; |
| end Check; |
| |
| -- Start of processing for Check_Choices |
| |
| begin |
| Raises_CE := False; |
| Others_Present := False; |
| |
| -- If Subtyp is not a discrete type or there was some other error, |
| -- then don't try any semantic checking on the choices since we have |
| -- a complete mess. |
| |
| if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then |
| return; |
| end if; |
| |
| -- If Subtyp is not a static subtype Ada 95 requires then we use the |
| -- bounds of its base type to determine the values covered by the |
| -- discrete choices. |
| |
| -- In Ada 2012, if the subtype has a non-static predicate the full |
| -- range of the base type must be covered as well. |
| |
| if Is_OK_Static_Subtype (Subtyp) then |
| if not Has_Predicates (Subtyp) |
| or else Has_Static_Predicate (Subtyp) |
| then |
| Bounds_Type := Subtyp; |
| else |
| Bounds_Type := Choice_Type; |
| end if; |
| |
| else |
| Bounds_Type := Choice_Type; |
| end if; |
| |
| -- Obtain static bounds of type, unless this is a generic formal |
| -- discrete type for which all choices will be non-static. |
| |
| if not Is_Generic_Type (Root_Type (Bounds_Type)) |
| or else Ekind (Bounds_Type) /= E_Enumeration_Type |
| then |
| Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)); |
| Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type)); |
| end if; |
| |
| if Choice_Type = Universal_Integer then |
| Expected_Type := Any_Integer; |
| else |
| Expected_Type := Choice_Type; |
| end if; |
| |
| -- Now loop through the case alternatives or record variants |
| |
| Alt := First (Alternatives); |
| while Present (Alt) loop |
| |
| -- If pragma, just analyze it |
| |
| if Nkind (Alt) = N_Pragma then |
| Analyze (Alt); |
| |
| -- Otherwise we have an alternative. In most cases the semantic |
| -- processing leaves the list of choices unchanged |
| |
| -- Check each choice against its base type |
| |
| else |
| Choice := First (Discrete_Choices (Alt)); |
| while Present (Choice) loop |
| Kind := Nkind (Choice); |
| |
| -- Choice is a Range |
| |
| if Kind = N_Range |
| or else (Kind = N_Attribute_Reference |
| and then Attribute_Name (Choice) = Name_Range) |
| then |
| Check (Choice, Low_Bound (Choice), High_Bound (Choice)); |
| |
| -- Choice is a subtype name |
| |
| elsif Is_Entity_Name (Choice) |
| and then Is_Type (Entity (Choice)) |
| then |
| -- Check for inappropriate type |
| |
| if not Covers (Expected_Type, Etype (Choice)) then |
| Wrong_Type (Choice, Choice_Type); |
| |
| -- Type is OK, so check further |
| |
| else |
| E := Entity (Choice); |
| |
| -- Case of predicated subtype |
| |
| if Has_Predicates (E) then |
| |
| -- Use of non-static predicate is an error |
| |
| if not Is_Discrete_Type (E) |
| or else not Has_Static_Predicate (E) |
| or else Has_Dynamic_Predicate_Aspect (E) |
| then |
| Bad_Predicated_Subtype_Use |
| ("cannot use subtype& with non-static " |
| & "predicate as case alternative", |
| Choice, E, Suggest_Static => True); |
| |
| -- Static predicate case |
| |
| else |
| declare |
| P : Node_Id; |
| C : Node_Id; |
| |
| begin |
| -- Loop through entries in predicate list, |
| -- checking each entry. Note that if the |
| -- list is empty, corresponding to a False |
| -- predicate, then no choices are checked. |
| |
| P := First (Static_Discrete_Predicate (E)); |
| while Present (P) loop |
| C := New_Copy (P); |
| Set_Sloc (C, Sloc (Choice)); |
| Check (C, Low_Bound (C), High_Bound (C)); |
| Next (P); |
| end loop; |
| end; |
| |
| Set_Has_SP_Choice (Alt); |
| end if; |
| |
| -- Not predicated subtype case |
| |
| elsif not Is_OK_Static_Subtype (E) then |
| Process_Non_Static_Choice (Choice); |
| else |
| Check |
| (Choice, Type_Low_Bound (E), Type_High_Bound (E)); |
| end if; |
| end if; |
| |
| -- Choice is a subtype indication |
| |
| elsif Kind = N_Subtype_Indication then |
| Resolve_Discrete_Subtype_Indication |
| (Choice, Expected_Type); |
| |
| if Etype (Choice) /= Any_Type then |
| declare |
| C : constant Node_Id := Constraint (Choice); |
| R : constant Node_Id := Range_Expression (C); |
| L : constant Node_Id := Low_Bound (R); |
| H : constant Node_Id := High_Bound (R); |
| |
| begin |
| E := Entity (Subtype_Mark (Choice)); |
| |
| if not Is_OK_Static_Subtype (E) then |
| Process_Non_Static_Choice (Choice); |
| |
| else |
| if Is_OK_Static_Expression (L) |
| and then |
| Is_OK_Static_Expression (H) |
| then |
| if Expr_Value (L) > Expr_Value (H) then |
| Process_Empty_Choice (Choice); |
| else |
| if Is_Out_Of_Range (L, E) then |
| Apply_Compile_Time_Constraint_Error |
| (L, "static value out of range", |
| CE_Range_Check_Failed); |
| end if; |
| |
| if Is_Out_Of_Range (H, E) then |
| Apply_Compile_Time_Constraint_Error |
| (H, "static value out of range", |
| CE_Range_Check_Failed); |
| end if; |
| end if; |
| end if; |
| |
| Check (Choice, L, H); |
| end if; |
| end; |
| end if; |
| |
| -- The others choice is only allowed for the last |
| -- alternative and as its only choice. |
| |
| elsif Kind = N_Others_Choice then |
| if not (Choice = First (Discrete_Choices (Alt)) |
| and then Choice = Last (Discrete_Choices (Alt)) |
| and then Alt = Last (Alternatives)) |
| then |
| Error_Msg_N |
| ("the choice OTHERS must appear alone and last", |
| Choice); |
| return; |
| end if; |
| |
| Others_Present := True; |
| Others_Choice := Choice; |
| |
| -- Only other possibility is an expression |
| |
| else |
| Check (Choice, Choice, Choice); |
| end if; |
| |
| -- Move to next choice |
| |
| Next (Choice); |
| end loop; |
| |
| Process_Associated_Node (Alt); |
| end if; |
| |
| Next (Alt); |
| end loop; |
| |
| -- Now we can create the Choice_Table, since we know how long |
| -- it needs to be so we can allocate exactly the right length. |
| |
| declare |
| Choice_Table : Choice_Table_Type (0 .. Num_Choices); |
| |
| begin |
| -- Now copy the items we collected in the linked list into this |
| -- newly allocated table (leave entry 0 unused for sorting). |
| |
| declare |
| T : Link_Ptr; |
| begin |
| for J in 1 .. Num_Choices loop |
| T := Choice_List; |
| Choice_List := T.Nxt; |
| Choice_Table (J) := T.Val; |
| Free (T); |
| end loop; |
| end; |
| |
| Check_Choice_Set |
| (Choice_Table, |
| Bounds_Type, |
| Subtyp, |
| Others_Present or else (Choice_Type = Universal_Integer), |
| N); |
| |
| -- If no others choice we are all done, otherwise we have one more |
| -- step, which is to set the Others_Discrete_Choices field of the |
| -- others choice (to contain all otherwise unspecified choices). |
| -- Skip this if CE is known to be raised. |
| |
| if Others_Present and not Raises_CE then |
| Expand_Others_Choice |
| (Case_Table => Choice_Table, |
| Others_Choice => Others_Choice, |
| Choice_Type => Bounds_Type); |
| end if; |
| end; |
| end Check_Choices; |
| |
| end Generic_Check_Choices; |
| |
| end Sem_Case; |
