+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S E M _ C A S E --
--- --
--- B o d y --
--- --
--- $Revision: 1.2.10.1 $
--- --
--- 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. --
--- 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 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;
projects / msp430-gcc.git / blobdiff