diff options
Diffstat (limited to 'gcc-4.3.1/gcc/ada/sem_intr.adb')
| -rw-r--r-- | gcc-4.3.1/gcc/ada/sem_intr.adb | 445 |
1 files changed, 445 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/sem_intr.adb b/gcc-4.3.1/gcc/ada/sem_intr.adb new file mode 100644 index 000000000..42d78baf7 --- /dev/null +++ b/gcc-4.3.1/gcc/ada/sem_intr.adb @@ -0,0 +1,445 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ I N T R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, 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 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 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. -- +-- -- +------------------------------------------------------------------------------ + +-- 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_FE + ("call to & requires static string argument!", N, Nam); + Why_Not_Static (Arg1); + + 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; + + -- Check for the case of freeing a non-null object which will raise + -- Constaint_Error. Issue warning here, do the expansion in Exp_Intr. + + elsif Cnam = Name_Free + and then Can_Never_Be_Null (Etype (Arg1)) + then + Error_Msg_N + ("freeing `NOT NULL` object will raise Constraint_Error?", N); + + -- 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 + Ret : constant Entity_Id := Etype (E); + Nam : constant Name_Id := Chars (E); + T1 : Entity_Id; + T2 : Entity_Id; + + begin + -- Aritnmetic operators + + if Nam = Name_Op_Add + or else + Nam = Name_Op_Subtract + or else + Nam = Name_Op_Multiply + or else + Nam = Name_Op_Divide + or else + Nam = Name_Op_Rem + or else + Nam = Name_Op_Mod + or else + Nam = Name_Op_Abs + then + T1 := Etype (First_Formal (E)); + + if No (Next_Formal (First_Formal (E))) then + + if Nam = Name_Op_Add + or else + Nam = Name_Op_Subtract + or else + Nam = Name_Op_Abs + then + T2 := T1; + + else + -- Previous error in declaration + + return; + end if; + + 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); + end if; + + -- Comparison operators + + elsif Nam = Name_Op_Eq + or else + Nam = Name_Op_Ge + or else + Nam = Name_Op_Gt + or else + Nam = Name_Op_Le + or else + Nam = Name_Op_Lt + or else + Nam = Name_Op_Ne + 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) then + Errint + ("types of intrinsic operator must have the same size", E, N); + end if; + + if Root_Type (Ret) /= Standard_Boolean then + Errint + ("result type of intrinsic comparison must be boolean", E, N); + end if; + + -- Exponentiation + + elsif Nam = Name_Op_Expon 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 not (Is_Integer_Type (T1) + or else + Is_Floating_Point_Type (T1)) + or else Root_Type (T1) /= Root_Type (Ret) + or else Root_Type (T2) /= Root_Type (Standard_Integer) + then + Errint ("incorrect operands for intrinsic operator", N, E); + end if; + + -- All other operators (are there any?) are not handled + + else + Errint ("incorrect context for ""Intrinsic"" convention", E, N); + return; + end if; + + if not Is_Numeric_Type (T1) then + Errint ("intrinsic operator can only apply to numeric types", 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 /= Name_To_Address + 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; |