File : sem_intr.adb
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-2016, 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 ------------------------------------------------------------------------------
25
26 -- Processing for intrinsic subprogram declarations
27
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 Opt; use Opt;
35 with Sem_Aux; use Sem_Aux;
36 with Sem_Eval; use Sem_Eval;
37 with Sem_Util; use Sem_Util;
38 with Sinfo; use Sinfo;
39 with Snames; use Snames;
40 with Stand; use Stand;
41 with Stringt; use Stringt;
42 with Uintp; use Uintp;
43
44 package body Sem_Intr is
45
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
49
50 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id);
51 -- Check use of intrinsic Exception_Message, Exception_Info or
52 -- Exception_Name, as used in the DEC compatible Current_Exceptions
53 -- package. In each case we must have a parameterless function that
54 -- returns type String.
55
56 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
57 -- Check that operator is one of the binary arithmetic operators, and that
58 -- the types involved both have underlying integer types.
59
60 procedure Check_Shift (E : Entity_Id; N : Node_Id);
61 -- Check intrinsic shift subprogram, the two arguments are the same
62 -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
63 -- declaration, and the node for the pragma argument, used for messages).
64
65 procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
66 -- Post error message for bad intrinsic, the message itself is posted
67 -- on the appropriate spec node and another message is placed on the
68 -- pragma itself, referring to the spec. S is the node in the spec on
69 -- which the message is to be placed, and N is the pragma argument node.
70
71 ------------------------------
72 -- Check_Exception_Function --
73 ------------------------------
74
75 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
76 begin
77 if not Ekind_In (E, E_Function, E_Generic_Function) then
78 Errint
79 ("intrinsic exception subprogram must be a function", E, N);
80
81 elsif Present (First_Formal (E)) then
82 Errint
83 ("intrinsic exception subprogram may not have parameters",
84 E, First_Formal (E));
85 return;
86
87 elsif Etype (E) /= Standard_String then
88 Errint
89 ("return type of exception subprogram must be String", E, N);
90 return;
91 end if;
92 end Check_Exception_Function;
93
94 --------------------------
95 -- Check_Intrinsic_Call --
96 --------------------------
97
98 procedure Check_Intrinsic_Call (N : Node_Id) is
99 Nam : constant Entity_Id := Entity (Name (N));
100 Arg1 : constant Node_Id := First_Actual (N);
101 Typ : Entity_Id;
102 Rtyp : Entity_Id;
103 Cnam : Name_Id;
104 Unam : Node_Id;
105
106 begin
107 -- Set argument type if argument present
108
109 if Present (Arg1) then
110 Typ := Etype (Arg1);
111 Rtyp := Underlying_Type (Root_Type (Typ));
112 end if;
113
114 -- Set intrinsic name (getting original name in the generic case)
115
116 Unam := Ultimate_Alias (Nam);
117
118 if Present (Parent (Unam))
119 and then Present (Generic_Parent (Parent (Unam)))
120 then
121 Cnam := Chars (Generic_Parent (Parent (Unam)));
122 else
123 Cnam := Chars (Nam);
124 end if;
125
126 -- For Import_xxx calls, argument must be static string. A string
127 -- literal is legal even in Ada 83 mode, where such literals are
128 -- not static.
129
130 if Nam_In (Cnam, Name_Import_Address,
131 Name_Import_Largest_Value,
132 Name_Import_Value)
133 then
134 if Etype (Arg1) = Any_Type
135 or else Raises_Constraint_Error (Arg1)
136 then
137 null;
138
139 elsif Nkind (Arg1) /= N_String_Literal
140 and then not Is_OK_Static_Expression (Arg1)
141 then
142 Error_Msg_FE
143 ("call to & requires static string argument!", N, Nam);
144 Why_Not_Static (Arg1);
145
146 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
147 Error_Msg_NE
148 ("call to & does not permit null string", N, Nam);
149 end if;
150
151 -- Check for the case of freeing a non-null object which will raise
152 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
153
154 elsif Cnam = Name_Unchecked_Deallocation
155 and then Can_Never_Be_Null (Etype (Arg1))
156 then
157 Error_Msg_N
158 ("freeing `NOT NULL` object will raise Constraint_Error??", N);
159
160 -- For unchecked deallocation, error to deallocate from empty pool.
161 -- Note: this test used to be in Exp_Intr as a warning, but AI 157
162 -- issues a binding interpretation that this should be an error, and
163 -- consequently it needs to be done in the semantic analysis so that
164 -- the error is issued even in semantics only mode.
165
166 elsif Cnam = Name_Unchecked_Deallocation
167 and then No_Pool_Assigned (Rtyp)
168 then
169 Error_Msg_N ("deallocation from empty storage pool!", N);
170
171 -- For now, no other special checks are required
172
173 else
174 return;
175 end if;
176 end Check_Intrinsic_Call;
177
178 ------------------------------
179 -- Check_Intrinsic_Operator --
180 ------------------------------
181
182 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
183 Ret : constant Entity_Id := Etype (E);
184 Nam : constant Name_Id := Chars (E);
185 T1 : Entity_Id;
186 T2 : Entity_Id;
187
188 begin
189 -- Arithmetic operators
190
191 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply,
192 Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs)
193 then
194 T1 := Etype (First_Formal (E));
195
196 if No (Next_Formal (First_Formal (E))) then
197 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then
198 T2 := T1;
199
200 -- Previous error in declaration
201
202 else
203 return;
204 end if;
205
206 else
207 T2 := Etype (Next_Formal (First_Formal (E)));
208 end if;
209
210 -- Same types, predefined operator will apply
211
212 if Root_Type (T1) = Root_Type (T2)
213 or else Root_Type (T1) = Root_Type (Ret)
214 then
215 null;
216
217 -- Expansion will introduce conversions if sizes are not equal
218
219 elsif Is_Integer_Type (Underlying_Type (T1))
220 and then Is_Integer_Type (Underlying_Type (T2))
221 and then Is_Integer_Type (Underlying_Type (Ret))
222 then
223 null;
224
225 else
226 Errint
227 ("types of intrinsic operator operands do not match", E, N);
228 end if;
229
230 -- Comparison operators
231
232 elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le,
233 Name_Op_Lt, Name_Op_Ne)
234 then
235 T1 := Etype (First_Formal (E));
236
237 -- Return if previous error in declaration, otherwise get T2 type
238
239 if No (Next_Formal (First_Formal (E))) then
240 Check_Error_Detected;
241 return;
242
243 else
244 T2 := Etype (Next_Formal (First_Formal (E)));
245 end if;
246
247 if Root_Type (T1) /= Root_Type (T2) then
248 Errint
249 ("types of intrinsic operator must have the same size", E, N);
250 end if;
251
252 if Root_Type (Ret) /= Standard_Boolean then
253 Errint
254 ("result type of intrinsic comparison must be boolean", E, N);
255 end if;
256
257 -- Exponentiation
258
259 elsif Nam = Name_Op_Expon then
260 T1 := Etype (First_Formal (E));
261
262 if No (Next_Formal (First_Formal (E))) then
263
264 -- Previous error in declaration
265
266 return;
267
268 else
269 T2 := Etype (Next_Formal (First_Formal (E)));
270 end if;
271
272 if not (Is_Integer_Type (T1)
273 or else
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)
277 then
278 Errint ("incorrect operands for intrinsic operator", N, E);
279 end if;
280
281 -- All other operators (are there any?) are not handled
282
283 else
284 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
285 return;
286 end if;
287
288 -- The type must be fully defined and numeric.
289
290 if No (Underlying_Type (T1))
291 or else not Is_Numeric_Type (Underlying_Type (T1))
292 then
293 Errint ("intrinsic operator can only apply to numeric types", E, N);
294 end if;
295 end Check_Intrinsic_Operator;
296
297 --------------------------------
298 -- Check_Intrinsic_Subprogram --
299 --------------------------------
300
301 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
302 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
303 Nam : Name_Id;
304
305 begin
306 if Present (Spec)
307 and then Present (Generic_Parent (Spec))
308 then
309 Nam := Chars (Generic_Parent (Spec));
310 else
311 Nam := Chars (E);
312 end if;
313
314 -- Check name is valid intrinsic name
315
316 Get_Name_String (Nam);
317
318 if Name_Buffer (1) /= 'O'
319 and then Nam /= Name_Asm
320 and then Nam /= Name_To_Address
321 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
322 then
323 Errint ("unrecognized intrinsic subprogram", E, N);
324
325 -- Shift cases. We allow user specification of intrinsic shift operators
326 -- for any numeric types.
327
328 elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left,
329 Name_Shift_Right, Name_Shift_Right_Arithmetic)
330 then
331 Check_Shift (E, N);
332
333 -- We always allow intrinsic specifications in language defined units
334 -- and in expanded code. We assume that the GNAT implementors know what
335 -- they are doing, and do not write or generate junk use of intrinsic.
336
337 elsif not Comes_From_Source (E)
338 or else not Comes_From_Source (N)
339 or else Is_Predefined_File_Name
340 (Unit_File_Name (Get_Source_Unit (N)))
341 then
342 null;
343
344 -- Exception functions
345
346 elsif Nam_In (Nam, Name_Exception_Information,
347 Name_Exception_Message,
348 Name_Exception_Name)
349 then
350 Check_Exception_Function (E, N);
351
352 -- Intrinsic operators
353
354 elsif Nkind (E) = N_Defining_Operator_Symbol then
355 Check_Intrinsic_Operator (E, N);
356
357 -- Source_Location and navigation functions
358
359 elsif Nam_In (Nam, Name_File,
360 Name_Line,
361 Name_Source_Location,
362 Name_Enclosing_Entity,
363 Name_Compilation_ISO_Date,
364 Name_Compilation_Date,
365 Name_Compilation_Time)
366 then
367 null;
368
369 -- For now, no other intrinsic subprograms are recognized in user code
370
371 else
372 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
373 end if;
374 end Check_Intrinsic_Subprogram;
375
376 -----------------
377 -- Check_Shift --
378 -----------------
379
380 procedure Check_Shift (E : Entity_Id; N : Node_Id) is
381 Arg1 : Node_Id;
382 Arg2 : Node_Id;
383 Size : Nat;
384 Typ1 : Entity_Id;
385 Typ2 : Entity_Id;
386 Ptyp1 : Node_Id;
387 Ptyp2 : Node_Id;
388
389 begin
390 if not Ekind_In (E, E_Function, E_Generic_Function) then
391 Errint ("intrinsic shift subprogram must be a function", E, N);
392 return;
393 end if;
394
395 Arg1 := First_Formal (E);
396
397 if Present (Arg1) then
398 Arg2 := Next_Formal (Arg1);
399 else
400 Arg2 := Empty;
401 end if;
402
403 if Arg1 = Empty or else Arg2 = Empty then
404 Errint ("intrinsic shift function must have two arguments", E, N);
405 return;
406 end if;
407
408 Typ1 := Etype (Arg1);
409 Typ2 := Etype (Arg2);
410
411 Ptyp1 := Parameter_Type (Parent (Arg1));
412 Ptyp2 := Parameter_Type (Parent (Arg2));
413
414 if not Is_Integer_Type (Typ1) then
415 Errint ("first argument to shift must be integer type", Ptyp1, N);
416 return;
417 end if;
418
419 if Typ2 /= Standard_Natural then
420 Errint ("second argument to shift must be type Natural", Ptyp2, N);
421 return;
422 end if;
423
424 -- type'Size (not 'Object_Size) must be one of the allowed values
425
426 Size := UI_To_Int (RM_Size (Typ1));
427
428 if Size /= 8 and then
429 Size /= 16 and then
430 Size /= 32 and then
431 Size /= 64
432 then
433 Errint
434 ("first argument for shift must have size 8, 16, 32 or 64",
435 Ptyp1, N);
436 return;
437
438 elsif Non_Binary_Modulus (Typ1) then
439 Errint ("shifts not allowed for nonbinary modular types", Ptyp1, N);
440
441 -- For modular type, modulus must be 2**8, 2**16, 2**32, or 2**64.
442 -- Don't apply to generic types, since we may not have a modulus value.
443
444 elsif Is_Modular_Integer_Type (Typ1)
445 and then not Is_Generic_Type (Typ1)
446 and then Modulus (Typ1) /= Uint_2 ** 8
447 and then Modulus (Typ1) /= Uint_2 ** 16
448 and then Modulus (Typ1) /= Uint_2 ** 32
449 and then Modulus (Typ1) /= Uint_2 ** 64
450 then
451 Errint
452 ("modular type for shift must have modulus of 2'*'*8, "
453 & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N);
454
455 elsif Etype (Arg1) /= Etype (E) then
456 Errint
457 ("first argument of shift must match return type", Ptyp1, N);
458 return;
459 end if;
460
461 Set_Has_Shift_Operator (Base_Type (Typ1));
462 end Check_Shift;
463
464 ------------
465 -- Errint --
466 ------------
467
468 procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
469 begin
470 -- Ignore errors on Intrinsic in Relaxed_RM_Semantics mode where we can
471 -- be more liberal.
472
473 if not Relaxed_RM_Semantics then
474 Error_Msg_N (Msg, S);
475 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
476 end if;
477 end Errint;
478
479 end Sem_Intr;