New Language: Ada

From-SVN: r45959

1 files changed, 352 insertions, 0 deletions

diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb
new file mode 100644
index 0000000..20b1918
--- /dev/null
+++ b/gcc/ada/sem_intr.adb
@@ -0,0 +1,352 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S E M _ I N T R                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.25 $
+--                                                                          --
+--          Copyright (C) 1992-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). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Processing for intrinsic subprogram declarations
+
+with Atree;    use Atree;
+with Einfo;    use Einfo;
+with Errout;   use Errout;
+with Fname;    use Fname;
+with Lib;      use Lib;
+with Namet;    use Namet;
+with Sem_Eval; use Sem_Eval;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Stringt;  use Stringt;
+with Targparm; use Targparm;
+with Uintp;    use Uintp;
+
+package body Sem_Intr is
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
+   --  Check use of intrinsic Exception_Message, Exception_Info or
+   --  Exception_Name, as used in the DEC compatible Current_Exceptions
+   --  package. In each case we must have a parameterless function that
+   --  returns type String.
+
+   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
+   --  Check that operator is one of the binary arithmetic operators, and
+   --  that the types involved have the same size.
+
+   procedure Check_Shift (E : Entity_Id; N : Node_Id);
+   --  Check intrinsic shift subprogram, the two arguments are the same
+   --  as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
+   --  declaration, and the node for the pragma argument, used for messages)
+
+   procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
+   --  Post error message for bad intrinsic, the message itself is posted
+   --  on the appropriate spec node and another message is placed on the
+   --  pragma itself, referring to the spec. S is the node in the spec on
+   --  which the message is to be placed, and N is the pragma argument node.
+
+   ------------------------------
+   -- Check_Exception_Function --
+   ------------------------------
+
+   procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
+   begin
+      if Ekind (E) /= E_Function
+        and then Ekind (E) /= E_Generic_Function
+      then
+         Errint
+           ("intrinsic exception subprogram must be a function", E, N);
+
+      elsif Present (First_Formal (E)) then
+         Errint
+           ("intrinsic exception subprogram may not have parameters",
+            E, First_Formal (E));
+         return;
+
+      elsif Etype (E) /= Standard_String then
+         Errint
+           ("return type of exception subprogram must be String", E, N);
+         return;
+      end if;
+   end Check_Exception_Function;
+
+   --------------------------
+   -- Check_Intrinsic_Call --
+   --------------------------
+
+   procedure Check_Intrinsic_Call (N : Node_Id) is
+      Nam  : constant Entity_Id := Entity (Name (N));
+      Cnam : constant Name_Id   := Chars (Nam);
+      Arg1 : constant Node_Id   := First_Actual (N);
+
+   begin
+      --  For Import_xxx calls, argument must be static string
+
+      if Cnam = Name_Import_Address
+           or else
+         Cnam = Name_Import_Largest_Value
+           or else
+         Cnam = Name_Import_Value
+      then
+         if Etype (Arg1) = Any_Type
+           or else Raises_Constraint_Error (Arg1)
+         then
+            null;
+
+         elsif not Is_Static_Expression (Arg1) then
+            Error_Msg_NE
+              ("call to & requires static string argument", N, Nam);
+
+         elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
+            Error_Msg_NE
+              ("call to & does not permit null string", N, Nam);
+
+         elsif OpenVMS_On_Target
+           and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
+         then
+            Error_Msg_NE
+              ("argument in call to & must be 31 characters or less", N, Nam);
+         end if;
+
+      --  For now, no other special checks are required
+
+      else
+         return;
+      end if;
+   end Check_Intrinsic_Call;
+
+   ------------------------------
+   -- Check_Intrinsic_Operator --
+   ------------------------------
+
+   procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
+      Nam : Name_Id := Chars (E);
+      T1  : Entity_Id;
+      T2  : Entity_Id;
+      Ret : constant Entity_Id := Etype (E);
+
+   begin
+      if Nam = Name_Op_Add
+        or else Nam = Name_Op_Subtract
+        or else Nam = Name_Op_Multiply
+        or else Nam = Name_Op_Divide
+      then
+         T1 := Etype (First_Formal (E));
+
+         if No (Next_Formal (First_Formal (E))) then
+
+            --  previous error in declaration.
+            return;
+
+         else
+            T2 := Etype (Next_Formal (First_Formal (E)));
+         end if;
+
+         if Root_Type (T1) /= Root_Type (T2)
+           or else Root_Type (T1) /= Root_Type (Ret)
+         then
+            Errint (
+              "types of intrinsic operator must have the same size", E, N);
+
+         elsif not Is_Numeric_Type (T1) then
+            Errint (
+              " intrinsic operator can only apply to numeric types", E, N);
+         end if;
+
+      else
+         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
+      end if;
+   end Check_Intrinsic_Operator;
+
+   --------------------------------
+   -- Check_Intrinsic_Subprogram --
+   --------------------------------
+
+   procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
+      Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
+      Nam  : Name_Id;
+
+   begin
+      if Present (Spec)
+        and then Present (Generic_Parent (Spec))
+      then
+         Nam := Chars (Generic_Parent (Spec));
+      else
+         Nam := Chars (E);
+      end if;
+
+      --  Check name is valid intrinsic name
+
+      Get_Name_String (Nam);
+
+      if Name_Buffer (1) /= 'O'
+        and then Nam /= Name_Asm
+        and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
+      then
+         Errint ("unrecognized intrinsic subprogram", E, N);
+
+      --  We always allow intrinsic specifications in language defined units
+      --  and in expanded code. We assume that the GNAT implemetors know what
+      --  they are doing, and do not write or generate junk use of intrinsic!
+
+      elsif not Comes_From_Source (E)
+        or else not Comes_From_Source (N)
+        or else Is_Predefined_File_Name
+                  (Unit_File_Name (Get_Source_Unit (N)))
+      then
+         null;
+
+      --  Shift cases. We allow user specification of intrinsic shift
+      --  operators for any numeric types.
+
+      elsif
+        Nam = Name_Rotate_Left
+          or else
+        Nam = Name_Rotate_Right
+          or else
+        Nam = Name_Shift_Left
+          or else
+        Nam = Name_Shift_Right
+          or else
+        Nam = Name_Shift_Right_Arithmetic
+      then
+         Check_Shift (E, N);
+
+      elsif
+        Nam = Name_Exception_Information
+          or else
+        Nam = Name_Exception_Message
+          or else
+        Nam = Name_Exception_Name
+      then
+         Check_Exception_Function (E, N);
+
+      elsif Nkind (E) = N_Defining_Operator_Symbol then
+         Check_Intrinsic_Operator (E, N);
+
+      elsif Nam = Name_File
+        or else Nam = Name_Line
+        or else Nam = Name_Source_Location
+        or else Nam = Name_Enclosing_Entity
+      then
+         null;
+
+      --  For now, no other intrinsic subprograms are recognized in user code
+
+      else
+         Errint ("incorrect context for ""Intrinsic"" convention", E, N);
+      end if;
+   end Check_Intrinsic_Subprogram;
+
+   -----------------
+   -- Check_Shift --
+   -----------------
+
+   procedure Check_Shift (E : Entity_Id; N : Node_Id) is
+      Arg1  : Node_Id;
+      Arg2  : Node_Id;
+      Size  : Nat;
+      Typ1  : Entity_Id;
+      Typ2  : Entity_Id;
+      Ptyp1 : Node_Id;
+      Ptyp2 : Node_Id;
+
+   begin
+      if Ekind (E) /= E_Function
+        and then Ekind (E) /= E_Generic_Function
+      then
+         Errint ("intrinsic shift subprogram must be a function", E, N);
+         return;
+      end if;
+
+      Arg1 := First_Formal (E);
+
+      if Present (Arg1) then
+         Arg2 := Next_Formal (Arg1);
+      else
+         Arg2 := Empty;
+      end if;
+
+      if Arg1 = Empty or else Arg2 = Empty then
+         Errint ("intrinsic shift function must have two arguments", E, N);
+         return;
+      end if;
+
+      Typ1 := Etype (Arg1);
+      Typ2 := Etype (Arg2);
+
+      Ptyp1 := Parameter_Type (Parent (Arg1));
+      Ptyp2 := Parameter_Type (Parent (Arg2));
+
+      if not Is_Integer_Type (Typ1) then
+         Errint ("first argument to shift must be integer type", Ptyp1, N);
+         return;
+      end if;
+
+      if Typ2 /= Standard_Natural then
+         Errint ("second argument to shift must be type Natural", Ptyp2, N);
+         return;
+      end if;
+
+      Size := UI_To_Int (Esize (Typ1));
+
+      if Size /= 8
+        and then Size /= 16
+        and then Size /= 32
+        and then Size /= 64
+      then
+         Errint
+           ("first argument for shift must have size 8, 16, 32 or 64",
+             Ptyp1, N);
+         return;
+
+      elsif Is_Modular_Integer_Type (Typ1)
+        and then Non_Binary_Modulus (Typ1)
+      then
+         Errint
+           ("shifts not allowed for non-binary modular types",
+            Ptyp1, N);
+
+      elsif Etype (Arg1) /= Etype (E) then
+         Errint
+           ("first argument of shift must match return type", Ptyp1, N);
+         return;
+      end if;
+   end Check_Shift;
+
+   ------------
+   -- Errint --
+   ------------
+
+   procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
+   begin
+      Error_Msg_N (Msg, S);
+      Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
+   end Errint;
+
+end Sem_Intr;