1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- Processing for intrinsic subprogram declarations
28 with Atree; use Atree;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Fname; use Fname;
33 with Namet; use Namet;
34 with Sem_Eval; use Sem_Eval;
35 with Sem_Util; use Sem_Util;
36 with Sinfo; use Sinfo;
37 with Snames; use Snames;
38 with Stand; use Stand;
39 with Stringt; use Stringt;
40 with Targparm; use Targparm;
41 with Uintp; use Uintp;
43 package body Sem_Intr is
45 -----------------------
46 -- Local Subprograms --
47 -----------------------
49 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
50 -- Check use of intrinsic Exception_Message, Exception_Info or
51 -- Exception_Name, as used in the DEC compatible Current_Exceptions
52 -- package. In each case we must have a parameterless function that
53 -- returns type String.
55 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
56 -- Check that operator is one of the binary arithmetic operators, and
57 -- that the types involved both have underlying integer types.
59 procedure Check_Shift (E : Entity_Id; N : Node_Id);
60 -- Check intrinsic shift subprogram, the two arguments are the same
61 -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
62 -- declaration, and the node for the pragma argument, used for messages)
64 procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
65 -- Post error message for bad intrinsic, the message itself is posted
66 -- on the appropriate spec node and another message is placed on the
67 -- pragma itself, referring to the spec. S is the node in the spec on
68 -- which the message is to be placed, and N is the pragma argument node.
70 ------------------------------
71 -- Check_Exception_Function --
72 ------------------------------
74 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
76 if not Ekind_In (E, E_Function, E_Generic_Function) then
78 ("intrinsic exception subprogram must be a function", E, N);
80 elsif Present (First_Formal (E)) then
82 ("intrinsic exception subprogram may not have parameters",
86 elsif Etype (E) /= Standard_String then
88 ("return type of exception subprogram must be String", E, N);
91 end Check_Exception_Function;
93 --------------------------
94 -- Check_Intrinsic_Call --
95 --------------------------
97 procedure Check_Intrinsic_Call (N : Node_Id) is
98 Nam : constant Entity_Id := Entity (Name (N));
99 Cnam : constant Name_Id := Chars (Nam);
100 Arg1 : constant Node_Id := First_Actual (N);
103 -- For Import_xxx calls, argument must be static string. A string
104 -- literal is legal even in Ada83 mode, where such literals are
107 if Cnam = Name_Import_Address
109 Cnam = Name_Import_Largest_Value
111 Cnam = Name_Import_Value
113 if Etype (Arg1) = Any_Type
114 or else Raises_Constraint_Error (Arg1)
118 elsif Nkind (Arg1) /= N_String_Literal
119 and then not Is_Static_Expression (Arg1)
122 ("call to & requires static string argument!", N, Nam);
123 Why_Not_Static (Arg1);
125 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
127 ("call to & does not permit null string", N, Nam);
129 elsif OpenVMS_On_Target
130 and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
133 ("argument in call to & must be 31 characters or less", N, Nam);
136 -- Check for the case of freeing a non-null object which will raise
137 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
139 elsif Cnam = Name_Free
140 and then Can_Never_Be_Null (Etype (Arg1))
143 ("freeing `NOT NULL` object will raise Constraint_Error?", N);
145 -- For now, no other special checks are required
150 end Check_Intrinsic_Call;
152 ------------------------------
153 -- Check_Intrinsic_Operator --
154 ------------------------------
156 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
157 Ret : constant Entity_Id := Etype (E);
158 Nam : constant Name_Id := Chars (E);
163 -- Arithmetic operators
167 Nam = Name_Op_Subtract
169 Nam = Name_Op_Multiply
179 T1 := Etype (First_Formal (E));
181 if No (Next_Formal (First_Formal (E))) then
185 Nam = Name_Op_Subtract
192 -- Previous error in declaration
198 T2 := Etype (Next_Formal (First_Formal (E)));
201 if Root_Type (T1) = Root_Type (T2)
202 or else Root_Type (T1) = Root_Type (Ret)
204 -- Same types, predefined operator will apply
208 elsif Is_Integer_Type (Underlying_Type (T1))
209 and then Is_Integer_Type (Underlying_Type (T2))
210 and then Is_Integer_Type (Underlying_Type (Ret))
212 -- Expansion will introduce conversions if sizes are not equal
218 ("types of intrinsic operator operands do not match", E, N);
221 -- Comparison operators
223 elsif Nam = Name_Op_Eq
235 T1 := Etype (First_Formal (E));
237 if No (Next_Formal (First_Formal (E))) then
239 -- Previous error in declaration
244 T2 := Etype (Next_Formal (First_Formal (E)));
247 if Root_Type (T1) /= Root_Type (T2) then
249 ("types of intrinsic operator must have the same size", E, N);
252 if Root_Type (Ret) /= Standard_Boolean then
254 ("result type of intrinsic comparison must be boolean", E, N);
259 elsif Nam = Name_Op_Expon then
260 T1 := Etype (First_Formal (E));
262 if No (Next_Formal (First_Formal (E))) then
264 -- Previous error in declaration
269 T2 := Etype (Next_Formal (First_Formal (E)));
272 if not (Is_Integer_Type (T1)
274 Is_Floating_Point_Type (T1))
275 or else Root_Type (T1) /= Root_Type (Ret)
276 or else Root_Type (T2) /= Root_Type (Standard_Integer)
278 Errint ("incorrect operands for intrinsic operator", N, E);
281 -- All other operators (are there any?) are not handled
284 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
288 if not Is_Numeric_Type (Underlying_Type (T1)) then
289 Errint ("intrinsic operator can only apply to numeric types", E, N);
291 end Check_Intrinsic_Operator;
293 --------------------------------
294 -- Check_Intrinsic_Subprogram --
295 --------------------------------
297 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
298 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
303 and then Present (Generic_Parent (Spec))
305 Nam := Chars (Generic_Parent (Spec));
310 -- Check name is valid intrinsic name
312 Get_Name_String (Nam);
314 if Name_Buffer (1) /= 'O'
315 and then Nam /= Name_Asm
316 and then Nam /= Name_To_Address
317 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
319 Errint ("unrecognized intrinsic subprogram", E, N);
321 -- We always allow intrinsic specifications in language defined units
322 -- and in expanded code. We assume that the GNAT implementors know what
323 -- they are doing, and do not write or generate junk use of intrinsic!
325 elsif not Comes_From_Source (E)
326 or else not Comes_From_Source (N)
327 or else Is_Predefined_File_Name
328 (Unit_File_Name (Get_Source_Unit (N)))
332 -- Shift cases. We allow user specification of intrinsic shift
333 -- operators for any numeric types.
336 Nam = Name_Rotate_Left
338 Nam = Name_Rotate_Right
340 Nam = Name_Shift_Left
342 Nam = Name_Shift_Right
344 Nam = Name_Shift_Right_Arithmetic
349 Nam = Name_Exception_Information
351 Nam = Name_Exception_Message
353 Nam = Name_Exception_Name
355 Check_Exception_Function (E, N);
357 elsif Nkind (E) = N_Defining_Operator_Symbol then
358 Check_Intrinsic_Operator (E, N);
360 elsif Nam = Name_File
361 or else Nam = Name_Line
362 or else Nam = Name_Source_Location
363 or else Nam = Name_Enclosing_Entity
367 -- For now, no other intrinsic subprograms are recognized in user code
370 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
372 end Check_Intrinsic_Subprogram;
378 procedure Check_Shift (E : Entity_Id; N : Node_Id) is
388 if not Ekind_In (E, E_Function, E_Generic_Function) then
389 Errint ("intrinsic shift subprogram must be a function", E, N);
393 Arg1 := First_Formal (E);
395 if Present (Arg1) then
396 Arg2 := Next_Formal (Arg1);
401 if Arg1 = Empty or else Arg2 = Empty then
402 Errint ("intrinsic shift function must have two arguments", E, N);
406 Typ1 := Etype (Arg1);
407 Typ2 := Etype (Arg2);
409 Ptyp1 := Parameter_Type (Parent (Arg1));
410 Ptyp2 := Parameter_Type (Parent (Arg2));
412 if not Is_Integer_Type (Typ1) then
413 Errint ("first argument to shift must be integer type", Ptyp1, N);
417 if Typ2 /= Standard_Natural then
418 Errint ("second argument to shift must be type Natural", Ptyp2, N);
422 Size := UI_To_Int (Esize (Typ1));
430 ("first argument for shift must have size 8, 16, 32 or 64",
434 elsif Non_Binary_Modulus (Typ1) then
436 ("shifts not allowed for non-binary modular types",
439 elsif Etype (Arg1) /= Etype (E) then
441 ("first argument of shift must match return type", Ptyp1, N);
450 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
452 Error_Msg_N (Msg, S);
453 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);