-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, 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- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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 Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Case; use Sem_Case;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+with GNAT.Heap_Sort_G;
package body Sem_Case is
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
+ -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algorithm
-- (this is not absolutely necessary but it makes the code more
-- efficient).
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.
+ -- 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.
+ -- Move routine for sorting the Choice_Table
+
+ package Sorting is new GNAT.Heap_Sort_G (Move_Choice, Lt_Choice);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
Lo : Uint;
Prev_Hi : Uint;
- -- Start processing for Check_Choices
+ -- Start of processing for Check_Choices
begin
-- Choice_Table must start at 0 which is an unused location used
return;
end if;
- Sort
- (Positive (Choice_Table'Last),
- Move_Choice'Unrestricted_Access,
- Lt_Choice'Unrestricted_Access);
+ Sorting.Sort (Positive (Choice_Table'Last));
Lo := Expr_Value (Choice_Table (1).Lo);
Hi := Expr_Value (Choice_Table (1).Hi);
C : Int;
begin
- -- For character, or wide character. If we are in 7-bit ASCII graphic
+ -- For character, or wide [wide] character. If 7-bit ASCII graphic
-- range, then build and return appropriate character literal name
- if Rtp = Standard_Character
- or else Rtp = Standard_Wide_Character
- then
+ if Is_Standard_Character_Type (Ctype) then
C := UI_To_Int (Value);
if C in 16#20# .. 16#7E# then
-- 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) := '(';
+ Add_Str_To_Name_Buffer ("'val(");
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) := ')';
+ Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
+ Add_Char_To_Name_Buffer (')');
return Name_Find;
end Choice_Image;
-- of literals to search. Instead, a N_Character_Literal node
-- is created with the appropriate Char_Code and Chars fields.
- if Root_Type (Choice_Type) = Standard_Character
- or else
- Root_Type (Choice_Type) = Standard_Wide_Character
- then
+ 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, Char_Code (UI_To_Int (Value)));
+ Set_Char_Literal_Value (Lit, Value);
Set_Etype (Lit, Choice_Type);
Set_Is_Static_Expression (Lit, True);
return Lit;
and then Comes_From_Source (Others_Choice)
and then Is_Empty_List (Choice_List)
then
- Error_Msg_N ("?others choice is empty", Others_Choice);
+ Error_Msg_N ("?OTHERS choice is redundant", Others_Choice);
+ Error_Msg_N ("\previous choices cover all values", Others_Choice);
end if;
end Expand_Others_Choice;
Raises_CE : out Boolean;
Others_Present : out Boolean)
is
+ pragma Assert (Choice_Table'First = 1);
+
E : Entity_Id;
Enode : Node_Id;
Bounds_Lo : Uint;
Bounds_Hi : Uint;
- -- The actual bounds of the above type.
+ -- The actual bounds of the above type
Expected_Type : Entity_Id;
-- The expected type of each choice. Equal to Choice_Type, except
else
Choice := First (Get_Choices (Alt));
-
while Present (Choice) loop
Analyze (Choice);
Kind := Nkind (Choice);
function Number_Of_Choices (N : Node_Id) return Nat is
Alt : Node_Id;
- -- A case statement alternative or a record variant.
+ -- A case statement alternative or a record variant
Choice : Node_Id;
Count : Nat := 0;
begin
- if not Present (Get_Alternatives (N)) then
+ if No (Get_Alternatives (N)) then
return 0;
end if;
OSDN Git Service
