| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C A S E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision$ |
| -- -- |
| -- Copyright (C) 1996-2001 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 2, 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 COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Einfo; use Einfo; |
| with Errout; use Errout; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Sem; use Sem; |
| 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 Uintp; use Uintp; |
| |
| with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; |
| |
| package body Sem_Case is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds; |
| -- This new array type is used as the actual table type for sorting |
| -- discrete choices. The reason for not using Choice_Table_Type, is that |
| -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algortim |
| -- (this is not absolutely necessary but it makes the code more |
| -- efficient). |
| |
| procedure Check_Choices |
| (Choice_Table : in out Sort_Choice_Table_Type; |
| Bounds_Type : Entity_Id; |
| Others_Present : Boolean; |
| Msg_Sloc : Source_Ptr); |
| -- This is the procedure which verifies that a set of case statement, |
| -- array aggregate or record variant choices has no duplicates, and |
| -- covers the range specified by Bounds_Type. Choice_Table contains the |
| -- discrete choices to check. These must start at position 1. |
| -- 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. |
| |
| 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. |
| |
| ------------------- |
| -- Check_Choices -- |
| ------------------- |
| |
| procedure Check_Choices |
| (Choice_Table : in out Sort_Choice_Table_Type; |
| Bounds_Type : Entity_Id; |
| Others_Present : Boolean; |
| Msg_Sloc : Source_Ptr) |
| is |
| |
| function Lt_Choice (C1, C2 : Natural) return Boolean; |
| -- Comparison routine for comparing Choice_Table entries. |
| -- Use the lower bound of each Choice as the key. |
| |
| procedure Move_Choice (From : Natural; To : Natural); |
| -- Move routine for sorting the Choice_Table. |
| |
| procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id); |
| procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint); |
| procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id); |
| procedure Issue_Msg (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. |
| |
| --------------- |
| -- Issue_Msg -- |
| --------------- |
| |
| procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is |
| begin |
| Issue_Msg (Expr_Value (Value1), Expr_Value (Value2)); |
| end Issue_Msg; |
| |
| procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is |
| begin |
| Issue_Msg (Expr_Value (Value1), Value2); |
| end Issue_Msg; |
| |
| procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is |
| begin |
| Issue_Msg (Value1, Expr_Value (Value2)); |
| end Issue_Msg; |
| |
| procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is |
| begin |
| -- In some situations, we call this with a null range, and |
| -- obviously we don't want to complain in this case! |
| |
| if Value1 > Value2 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 Issue_Msg; |
| |
| --------------- |
| -- 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; |
| |
| ----------------- |
| -- Move_Choice -- |
| ----------------- |
| |
| procedure Move_Choice (From : Natural; To : Natural) is |
| begin |
| Choice_Table (Nat (To)) := Choice_Table (Nat (From)); |
| end Move_Choice; |
| |
| -- Variables local to Check_Choices |
| |
| Choice : Node_Id; |
| Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); |
| Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); |
| |
| Prev_Choice : Node_Id; |
| |
| Hi : Uint; |
| Lo : Uint; |
| Prev_Hi : Uint; |
| |
| -- Start processing for Check_Choices |
| |
| begin |
| |
| -- Choice_Table must start at 0 which is an unused location used |
| -- by the sorting algorithm. However the first valid position for |
| -- a discrete choice is 1. |
| |
| pragma Assert (Choice_Table'First = 0); |
| |
| if Choice_Table'Last = 0 then |
| if not Others_Present then |
| Issue_Msg (Bounds_Lo, Bounds_Hi); |
| end if; |
| return; |
| end if; |
| |
| Sort |
| (Positive (Choice_Table'Last), |
| Move_Choice'Unrestricted_Access, |
| Lt_Choice'Unrestricted_Access); |
| |
| Lo := Expr_Value (Choice_Table (1).Lo); |
| Hi := Expr_Value (Choice_Table (1).Hi); |
| Prev_Hi := Hi; |
| |
| if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then |
| Issue_Msg (Bounds_Lo, Lo - 1); |
| end if; |
| |
| for J in 2 .. Choice_Table'Last loop |
| Lo := Expr_Value (Choice_Table (J).Lo); |
| Hi := Expr_Value (Choice_Table (J).Hi); |
| |
| if Lo <= Prev_Hi then |
| Prev_Choice := Choice_Table (J - 1).Node; |
| Choice := Choice_Table (J).Node; |
| |
| if Sloc (Prev_Choice) <= Sloc (Choice) then |
| Error_Msg_Sloc := Sloc (Prev_Choice); |
| Error_Msg_N ("duplication of choice value#", Choice); |
| else |
| Error_Msg_Sloc := Sloc (Choice); |
| Error_Msg_N ("duplication of choice value#", Prev_Choice); |
| end if; |
| |
| elsif not Others_Present and then Lo /= Prev_Hi + 1 then |
| Issue_Msg (Prev_Hi + 1, Lo - 1); |
| end if; |
| |
| Prev_Hi := Hi; |
| end loop; |
| |
| if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then |
| Issue_Msg (Hi + 1, Bounds_Hi); |
| end if; |
| end Check_Choices; |
| |
| ------------------ |
| -- 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 character. If we are in 7-bit ASCII graphic |
| -- range, then build and return appropriate character literal name |
| |
| if Rtp = Standard_Character |
| or else Rtp = Standard_Wide_Character |
| 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))); |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := '''; |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := 'v'; |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := 'a'; |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := 'l'; |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := '('; |
| |
| UI_Image (Value); |
| |
| for J in 1 .. UI_Image_Length loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := UI_Image_Buffer (J); |
| end loop; |
| |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := ')'; |
| return Name_Find; |
| end Choice_Image; |
| |
| ----------- |
| -- No_OP -- |
| ----------- |
| |
| procedure No_OP (C : Node_Id) is |
| begin |
| null; |
| end No_OP; |
| |
| -------------------------------- |
| -- Generic_Choices_Processing -- |
| -------------------------------- |
| |
| package body Generic_Choices_Processing is |
| |
| --------------------- |
| -- Analyze_Choices -- |
| --------------------- |
| |
| procedure Analyze_Choices |
| (N : Node_Id; |
| Subtyp : Entity_Id; |
| Choice_Table : in out Choice_Table_Type; |
| Last_Choice : out Nat; |
| Raises_CE : out Boolean; |
| Others_Present : out Boolean) |
| is |
| |
| Nb_Choices : constant Nat := Choice_Table'Length; |
| Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices); |
| |
| 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 th 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. |
| |
| procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); |
| -- Checks the validity of the bounds of a choice. When the bounds |
| -- are static and no error occurred the bounds are entered into |
| -- 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_Static_Expression (Lo) |
| or else not Is_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; |
| |
| -- 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 bound out of range. |
| |
| if Lo_Val < Bounds_Lo then |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Bounds_Lo; |
| Error_Msg_N ("minimum allowed choice value is^", Lo); |
| else |
| Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type); |
| Error_Msg_N ("minimum allowed choice value is%", Lo); |
| end if; |
| |
| elsif Hi_Val > Bounds_Hi then |
| if Is_Integer_Type (Bounds_Type) then |
| Error_Msg_Uint_1 := Bounds_Hi; |
| Error_Msg_N ("maximum allowed choice value is^", Hi); |
| else |
| Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type); |
| Error_Msg_N ("maximum allowed choice value is%", Hi); |
| end if; |
| end if; |
| |
| -- We still store the bounds in the table, even if they are out |
| -- of range, since this may prevent unnecessary cascaded errors |
| -- for values that are covered by such an excessive range. |
| |
| Last_Choice := Last_Choice + 1; |
| Sort_Choice_Table (Last_Choice).Lo := Lo; |
| Sort_Choice_Table (Last_Choice).Hi := Hi; |
| Sort_Choice_Table (Last_Choice).Node := Choice; |
| end Check; |
| |
| -- Variables local to Analyze_Choices |
| |
| Alt : Node_Id; |
| -- A case statement alternative, an array aggregate component |
| -- association or a variant in a record type declaration |
| |
| Choice : Node_Id; |
| Kind : Node_Kind; |
| -- The node kind of the current Choice. |
| |
| E : Entity_Id; |
| |
| -- Start of processing for Analyze_Choices |
| |
| begin |
| Last_Choice := 0; |
| Raises_CE := False; |
| Others_Present := False; |
| |
| -- 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. |
| |
| if Is_OK_Static_Subtype (Subtyp) then |
| Bounds_Type := Subtyp; |
| 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 statement alternatives or array |
| -- aggregate component associations or record variants. |
| |
| Alt := First (Get_Alternatives (N)); |
| while Present (Alt) loop |
| |
| -- If pragma, just analyze it |
| |
| if Nkind (Alt) = N_Pragma then |
| Analyze (Alt); |
| |
| -- Otherwise check each choice against its base type |
| |
| else |
| Choice := First (Get_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); |
| 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 |
| if not Covers (Expected_Type, Etype (Choice)) then |
| Wrong_Type (Choice, Choice_Type); |
| |
| else |
| E := Entity (Choice); |
| |
| if not Is_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_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"); |
| end if; |
| |
| if Is_Out_Of_Range (H, E) then |
| Apply_Compile_Time_Constraint_Error |
| (H, "static value out of range"); |
| 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 (Get_Choices (Alt)) |
| and then Choice = Last (Get_Choices (Alt)) |
| and then Alt = Last (Get_Alternatives (N))) |
| then |
| Error_Msg_N |
| ("the choice OTHERS must appear alone and last", |
| Choice); |
| return; |
| end if; |
| |
| Others_Present := True; |
| |
| -- Only other possibility is an expression |
| |
| else |
| Resolve (Choice, Expected_Type); |
| Check (Choice, Choice, Choice); |
| end if; |
| |
| Next (Choice); |
| end loop; |
| |
| Process_Associated_Node (Alt); |
| end if; |
| |
| Next (Alt); |
| end loop; |
| |
| Check_Choices |
| (Sort_Choice_Table (0 .. Last_Choice), |
| Bounds_Type, |
| Others_Present or else (Choice_Type = Universal_Integer), |
| Sloc (N)); |
| |
| -- Now copy the sorted discrete choices |
| |
| for J in 1 .. Last_Choice loop |
| Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J); |
| end loop; |
| |
| end Analyze_Choices; |
| |
| ----------------------- |
| -- Number_Of_Choices -- |
| ----------------------- |
| |
| function Number_Of_Choices (N : Node_Id) return Nat is |
| Alt : Node_Id; |
| -- A case statement alternative, an array aggregate component |
| -- association or a record variant. |
| |
| Choice : Node_Id; |
| Count : Nat := 0; |
| |
| begin |
| if not Present (Get_Alternatives (N)) then |
| return 0; |
| end if; |
| |
| Alt := First_Non_Pragma (Get_Alternatives (N)); |
| while Present (Alt) loop |
| |
| Choice := First (Get_Choices (Alt)); |
| while Present (Choice) loop |
| if Nkind (Choice) /= N_Others_Choice then |
| Count := Count + 1; |
| end if; |
| |
| Next (Choice); |
| end loop; |
| |
| Next_Non_Pragma (Alt); |
| end loop; |
| |
| return Count; |
| end Number_Of_Choices; |
| |
| end Generic_Choices_Processing; |
| |
| end Sem_Case; |
