------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ I N T R -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2013, 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_Aux; use Sem_Aux; 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 both have underlying integer types. 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 not Ekind_In (E, E_Function, 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)); Arg1 : constant Node_Id := First_Actual (N); Typ : Entity_Id; Rtyp : Entity_Id; Cnam : Name_Id; Unam : Node_Id; begin -- Set argument type if argument present if Present (Arg1) then Typ := Etype (Arg1); Rtyp := Underlying_Type (Root_Type (Typ)); end if; -- Set intrinsic name (getting original name in the generic case) Unam := Ultimate_Alias (Nam); if Present (Parent (Unam)) and then Present (Generic_Parent (Parent (Unam))) then Cnam := Chars (Generic_Parent (Parent (Unam))); else Cnam := Chars (Nam); end if; -- For Import_xxx calls, argument must be static string. A string -- literal is legal even in Ada 83 mode, where such literals are -- not static. if Nam_In (Cnam, Name_Import_Address, Name_Import_Largest_Value, Name_Import_Value) then if Etype (Arg1) = Any_Type or else Raises_Constraint_Error (Arg1) then null; elsif Nkind (Arg1) /= N_String_Literal and then 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 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr. elsif Cnam = Name_Unchecked_Deallocation and then Can_Never_Be_Null (Etype (Arg1)) then Error_Msg_N ("freeing `NOT NULL` object will raise Constraint_Error??", N); -- For unchecked deallocation, error to deallocate from empty pool. -- Note: this test used to be in Exp_Intr as a warning, but AI 157 -- issues a binding interpretation that this should be an error, and -- consequently it needs to be done in the semantic analysis so that -- the error is issued even in semantics only mode. elsif Cnam = Name_Unchecked_Deallocation and then No_Pool_Assigned (Rtyp) then Error_Msg_N ("deallocation from empty storage pool!", 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 -- Arithmetic operators if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply, Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs) then T1 := Etype (First_Formal (E)); if No (Next_Formal (First_Formal (E))) then if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then T2 := T1; -- Previous error in declaration else return; end if; else T2 := Etype (Next_Formal (First_Formal (E))); end if; -- Same types, predefined operator will apply if Root_Type (T1) = Root_Type (T2) or else Root_Type (T1) = Root_Type (Ret) then null; -- Expansion will introduce conversions if sizes are not equal elsif Is_Integer_Type (Underlying_Type (T1)) and then Is_Integer_Type (Underlying_Type (T2)) and then Is_Integer_Type (Underlying_Type (Ret)) then null; else Errint ("types of intrinsic operator operands do not match", E, N); end if; -- Comparison operators elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le, Name_Op_Lt, Name_Op_Ne) then T1 := Etype (First_Formal (E)); -- Return if previous error in declaration, otherwise get T2 type if No (Next_Formal (First_Formal (E))) then Check_Error_Detected; 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; -- The type must be fully defined and numeric. if No (Underlying_Type (T1)) or else not Is_Numeric_Type (Underlying_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); -- Shift cases. We allow user specification of intrinsic shift operators -- for any numeric types. elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left, Name_Shift_Right, Name_Shift_Right_Arithmetic) then Check_Shift (E, N); -- We always allow intrinsic specifications in language defined units -- and in expanded code. We assume that the GNAT implementors 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; -- Exception functions elsif Nam_In (Nam, Name_Exception_Information, Name_Exception_Message, Name_Exception_Name) then Check_Exception_Function (E, N); -- Intrinsic operators elsif Nkind (E) = N_Defining_Operator_Symbol then Check_Intrinsic_Operator (E, N); -- Source_Location and navigation functions elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location, 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 not Ekind_In (E, E_Function, 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; -- type'Size (not 'Object_Size) must be one of the allowed values Size := UI_To_Int (RM_Size (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 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; Set_Has_Shift_Operator (Base_Type (Typ1)); 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;