2014-10-31 Hristian Kirtchev <kirtchev@adacore.com>
[official-gcc.git] / gcc / ada / sem_intr.adb
blobf61b47aed94e1a272e56c2bfcaf499e4c5aa2bfe
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ I N T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
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;
32 with Lib; use Lib;
33 with Namet; use Namet;
34 with Sem_Aux; use Sem_Aux;
35 with Sem_Eval; use Sem_Eval;
36 with Sem_Util; use Sem_Util;
37 with Sinfo; use Sinfo;
38 with Snames; use Snames;
39 with Stand; use Stand;
40 with Stringt; use Stringt;
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 that
57 -- 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
75 begin
76 if not Ekind_In (E, E_Function, E_Generic_Function) then
77 Errint
78 ("intrinsic exception subprogram must be a function", E, N);
80 elsif Present (First_Formal (E)) then
81 Errint
82 ("intrinsic exception subprogram may not have parameters",
83 E, First_Formal (E));
84 return;
86 elsif Etype (E) /= Standard_String then
87 Errint
88 ("return type of exception subprogram must be String", E, N);
89 return;
90 end if;
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 Arg1 : constant Node_Id := First_Actual (N);
100 Typ : Entity_Id;
101 Rtyp : Entity_Id;
102 Cnam : Name_Id;
103 Unam : Node_Id;
105 begin
106 -- Set argument type if argument present
108 if Present (Arg1) then
109 Typ := Etype (Arg1);
110 Rtyp := Underlying_Type (Root_Type (Typ));
111 end if;
113 -- Set intrinsic name (getting original name in the generic case)
115 Unam := Ultimate_Alias (Nam);
117 if Present (Parent (Unam))
118 and then Present (Generic_Parent (Parent (Unam)))
119 then
120 Cnam := Chars (Generic_Parent (Parent (Unam)));
121 else
122 Cnam := Chars (Nam);
123 end if;
125 -- For Import_xxx calls, argument must be static string. A string
126 -- literal is legal even in Ada 83 mode, where such literals are
127 -- not static.
129 if Nam_In (Cnam, Name_Import_Address,
130 Name_Import_Largest_Value,
131 Name_Import_Value)
132 then
133 if Etype (Arg1) = Any_Type
134 or else Raises_Constraint_Error (Arg1)
135 then
136 null;
138 elsif Nkind (Arg1) /= N_String_Literal
139 and then not Is_OK_Static_Expression (Arg1)
140 then
141 Error_Msg_FE
142 ("call to & requires static string argument!", N, Nam);
143 Why_Not_Static (Arg1);
145 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
146 Error_Msg_NE
147 ("call to & does not permit null string", N, Nam);
148 end if;
150 -- Check for the case of freeing a non-null object which will raise
151 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
153 elsif Cnam = Name_Unchecked_Deallocation
154 and then Can_Never_Be_Null (Etype (Arg1))
155 then
156 Error_Msg_N
157 ("freeing `NOT NULL` object will raise Constraint_Error??", N);
159 -- For unchecked deallocation, error to deallocate from empty pool.
160 -- Note: this test used to be in Exp_Intr as a warning, but AI 157
161 -- issues a binding interpretation that this should be an error, and
162 -- consequently it needs to be done in the semantic analysis so that
163 -- the error is issued even in semantics only mode.
165 elsif Cnam = Name_Unchecked_Deallocation
166 and then No_Pool_Assigned (Rtyp)
167 then
168 Error_Msg_N ("deallocation from empty storage pool!", N);
170 -- For now, no other special checks are required
172 else
173 return;
174 end if;
175 end Check_Intrinsic_Call;
177 ------------------------------
178 -- Check_Intrinsic_Operator --
179 ------------------------------
181 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
182 Ret : constant Entity_Id := Etype (E);
183 Nam : constant Name_Id := Chars (E);
184 T1 : Entity_Id;
185 T2 : Entity_Id;
187 begin
188 -- Arithmetic operators
190 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply,
191 Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs)
192 then
193 T1 := Etype (First_Formal (E));
195 if No (Next_Formal (First_Formal (E))) then
196 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then
197 T2 := T1;
199 -- Previous error in declaration
201 else
202 return;
203 end if;
205 else
206 T2 := Etype (Next_Formal (First_Formal (E)));
207 end if;
209 -- Same types, predefined operator will apply
211 if Root_Type (T1) = Root_Type (T2)
212 or else Root_Type (T1) = Root_Type (Ret)
213 then
214 null;
216 -- Expansion will introduce conversions if sizes are not equal
218 elsif Is_Integer_Type (Underlying_Type (T1))
219 and then Is_Integer_Type (Underlying_Type (T2))
220 and then Is_Integer_Type (Underlying_Type (Ret))
221 then
222 null;
224 else
225 Errint
226 ("types of intrinsic operator operands do not match", E, N);
227 end if;
229 -- Comparison operators
231 elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le,
232 Name_Op_Lt, Name_Op_Ne)
233 then
234 T1 := Etype (First_Formal (E));
236 -- Return if previous error in declaration, otherwise get T2 type
238 if No (Next_Formal (First_Formal (E))) then
239 Check_Error_Detected;
240 return;
242 else
243 T2 := Etype (Next_Formal (First_Formal (E)));
244 end if;
246 if Root_Type (T1) /= Root_Type (T2) then
247 Errint
248 ("types of intrinsic operator must have the same size", E, N);
249 end if;
251 if Root_Type (Ret) /= Standard_Boolean then
252 Errint
253 ("result type of intrinsic comparison must be boolean", E, N);
254 end if;
256 -- Exponentiation
258 elsif Nam = Name_Op_Expon then
259 T1 := Etype (First_Formal (E));
261 if No (Next_Formal (First_Formal (E))) then
263 -- Previous error in declaration
265 return;
267 else
268 T2 := Etype (Next_Formal (First_Formal (E)));
269 end if;
271 if not (Is_Integer_Type (T1)
272 or else
273 Is_Floating_Point_Type (T1))
274 or else Root_Type (T1) /= Root_Type (Ret)
275 or else Root_Type (T2) /= Root_Type (Standard_Integer)
276 then
277 Errint ("incorrect operands for intrinsic operator", N, E);
278 end if;
280 -- All other operators (are there any?) are not handled
282 else
283 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
284 return;
285 end if;
287 -- The type must be fully defined and numeric.
289 if No (Underlying_Type (T1))
290 or else not Is_Numeric_Type (Underlying_Type (T1))
291 then
292 Errint ("intrinsic operator can only apply to numeric types", E, N);
293 end if;
294 end Check_Intrinsic_Operator;
296 --------------------------------
297 -- Check_Intrinsic_Subprogram --
298 --------------------------------
300 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
301 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
302 Nam : Name_Id;
304 begin
305 if Present (Spec)
306 and then Present (Generic_Parent (Spec))
307 then
308 Nam := Chars (Generic_Parent (Spec));
309 else
310 Nam := Chars (E);
311 end if;
313 -- Check name is valid intrinsic name
315 Get_Name_String (Nam);
317 if Name_Buffer (1) /= 'O'
318 and then Nam /= Name_Asm
319 and then Nam /= Name_To_Address
320 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
321 then
322 Errint ("unrecognized intrinsic subprogram", E, N);
324 -- Shift cases. We allow user specification of intrinsic shift operators
325 -- for any numeric types.
327 elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left,
328 Name_Shift_Right, Name_Shift_Right_Arithmetic)
329 then
330 Check_Shift (E, N);
332 -- We always allow intrinsic specifications in language defined units
333 -- and in expanded code. We assume that the GNAT implementors know what
334 -- they are doing, and do not write or generate junk use of intrinsic.
336 elsif not Comes_From_Source (E)
337 or else not Comes_From_Source (N)
338 or else Is_Predefined_File_Name
339 (Unit_File_Name (Get_Source_Unit (N)))
340 then
341 null;
343 -- Exception functions
345 elsif Nam_In (Nam, Name_Exception_Information,
346 Name_Exception_Message,
347 Name_Exception_Name)
348 then
349 Check_Exception_Function (E, N);
351 -- Intrinsic operators
353 elsif Nkind (E) = N_Defining_Operator_Symbol then
354 Check_Intrinsic_Operator (E, N);
356 -- Source_Location and navigation functions
358 elsif Nam_In (Nam, Name_File,
359 Name_Line,
360 Name_Source_Location,
361 Name_Enclosing_Entity,
362 Name_Compilation_Date,
363 Name_Compilation_Time)
364 then
365 null;
367 -- For now, no other intrinsic subprograms are recognized in user code
369 else
370 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
371 end if;
372 end Check_Intrinsic_Subprogram;
374 -----------------
375 -- Check_Shift --
376 -----------------
378 procedure Check_Shift (E : Entity_Id; N : Node_Id) is
379 Arg1 : Node_Id;
380 Arg2 : Node_Id;
381 Size : Nat;
382 Typ1 : Entity_Id;
383 Typ2 : Entity_Id;
384 Ptyp1 : Node_Id;
385 Ptyp2 : Node_Id;
387 begin
388 if not Ekind_In (E, E_Function, E_Generic_Function) then
389 Errint ("intrinsic shift subprogram must be a function", E, N);
390 return;
391 end if;
393 Arg1 := First_Formal (E);
395 if Present (Arg1) then
396 Arg2 := Next_Formal (Arg1);
397 else
398 Arg2 := Empty;
399 end if;
401 if Arg1 = Empty or else Arg2 = Empty then
402 Errint ("intrinsic shift function must have two arguments", E, N);
403 return;
404 end if;
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);
414 return;
415 end if;
417 if Typ2 /= Standard_Natural then
418 Errint ("second argument to shift must be type Natural", Ptyp2, N);
419 return;
420 end if;
422 -- type'Size (not 'Object_Size) must be one of the allowed values
424 Size := UI_To_Int (RM_Size (Typ1));
426 if Size /= 8 and then
427 Size /= 16 and then
428 Size /= 32 and then
429 Size /= 64
430 then
431 Errint
432 ("first argument for shift must have size 8, 16, 32 or 64",
433 Ptyp1, N);
434 return;
436 elsif Non_Binary_Modulus (Typ1) then
437 Errint
438 ("shifts not allowed for non-binary modular types", Ptyp1, N);
440 elsif Etype (Arg1) /= Etype (E) then
441 Errint
442 ("first argument of shift must match return type", Ptyp1, N);
443 return;
444 end if;
446 Set_Has_Shift_Operator (Base_Type (Typ1));
447 end Check_Shift;
449 ------------
450 -- Errint --
451 ------------
453 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
454 begin
455 Error_Msg_N (Msg, S);
456 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
457 end Errint;
459 end Sem_Intr;