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
procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
procedure Check_Shift (E : Entity_Id; N : Node_Id);
procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
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;
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
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;
else
return;
end if;
end Check_Intrinsic_Call;
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
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
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;
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
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;
elsif Nam = Name_Op_Expon then
T1 := Etype (First_Formal (E));
if No (Next_Formal (First_Formal (E))) then
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;
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;
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;
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);
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;
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;
else
Errint ("incorrect context for ""Intrinsic"" convention", E, N);
end if;
end Check_Intrinsic_Subprogram;
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;
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;