New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45959 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 681 insertions, 0 deletions

diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
new file mode 100644
index 00000000000..a9326c36384
--- /dev/null
+++ b/gcc/ada/sem_case.adb
@@ -0,0 +1,681 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ C A S E                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.13 $
+--                                                                          --
+--          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
+            Name_Buffer (1) := ''';
+            Name_Buffer (2) := Character'Val (C);
+            Name_Buffer (3) := ''';
+            Name_Len := 3;
+            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;