1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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;
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;
44 package body Sem_Intr is
46 -----------------------
47 -- Local Subprograms --
48 -----------------------
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.
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.
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).
66 (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False);
67 -- Post error message for bad intrinsic, the message itself is posted
68 -- on the appropriate spec node and another message is placed on the
69 -- pragma itself, referring to the spec. S is the node in the spec on
70 -- which the message is to be placed, and N is the pragma argument node.
71 -- Relaxed is True if the message should not be emitted in
72 -- Relaxed_RM_Semantics mode.
74 ------------------------------
75 -- Check_Exception_Function --
76 ------------------------------
78 procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
80 if not Ekind_In (E, E_Function, E_Generic_Function) then
82 ("intrinsic exception subprogram must be a function", E, N);
84 elsif Present (First_Formal (E)) then
86 ("intrinsic exception subprogram may not have parameters",
90 elsif Etype (E) /= Standard_String then
92 ("return type of exception subprogram must be String", E, N);
95 end Check_Exception_Function;
97 --------------------------
98 -- Check_Intrinsic_Call --
99 --------------------------
101 procedure Check_Intrinsic_Call (N : Node_Id) is
102 Nam : constant Entity_Id := Entity (Name (N));
103 Arg1 : constant Node_Id := First_Actual (N);
110 -- Set argument type if argument present
112 if Present (Arg1) then
114 Rtyp := Underlying_Type (Root_Type (Typ));
117 -- Set intrinsic name (getting original name in the generic case)
119 Unam := Ultimate_Alias (Nam);
121 if Present (Parent (Unam))
122 and then Present (Generic_Parent (Parent (Unam)))
124 Cnam := Chars (Generic_Parent (Parent (Unam)));
129 -- For Import_xxx calls, argument must be static string. A string
130 -- literal is legal even in Ada 83 mode, where such literals are
133 if Nam_In (Cnam, Name_Import_Address,
134 Name_Import_Largest_Value,
137 if Etype (Arg1) = Any_Type
138 or else Raises_Constraint_Error (Arg1)
142 elsif Nkind (Arg1) /= N_String_Literal
143 and then not Is_OK_Static_Expression (Arg1)
146 ("call to & requires static string argument!", N, Nam);
147 Why_Not_Static (Arg1);
149 elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
151 ("call to & does not permit null string", N, Nam);
154 -- Check for the case of freeing a non-null object which will raise
155 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
157 elsif Cnam = Name_Unchecked_Deallocation
158 and then Can_Never_Be_Null (Etype (Arg1))
161 ("freeing `NOT NULL` object will raise Constraint_Error??", N);
163 -- For unchecked deallocation, error to deallocate from empty pool.
164 -- Note: this test used to be in Exp_Intr as a warning, but AI 157
165 -- issues a binding interpretation that this should be an error, and
166 -- consequently it needs to be done in the semantic analysis so that
167 -- the error is issued even in semantics only mode.
169 elsif Cnam = Name_Unchecked_Deallocation
170 and then No_Pool_Assigned (Rtyp)
172 Error_Msg_N ("deallocation from empty storage pool!", N);
174 -- For now, no other special checks are required
179 end Check_Intrinsic_Call;
181 ------------------------------
182 -- Check_Intrinsic_Operator --
183 ------------------------------
185 procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id) is
186 Ret : constant Entity_Id := Etype (E);
187 Nam : constant Name_Id := Chars (E);
192 -- Arithmetic operators
194 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply,
195 Name_Op_Divide, Name_Op_Rem, Name_Op_Mod, Name_Op_Abs)
197 T1 := Etype (First_Formal (E));
199 if No (Next_Formal (First_Formal (E))) then
200 if Nam_In (Nam, Name_Op_Add, Name_Op_Subtract, Name_Op_Abs) then
203 -- Previous error in declaration
210 T2 := Etype (Next_Formal (First_Formal (E)));
213 -- Same types, predefined operator will apply
215 if Root_Type (T1) = Root_Type (T2)
216 or else Root_Type (T1) = Root_Type (Ret)
220 -- Expansion will introduce conversions if sizes are not equal
222 elsif Is_Integer_Type (Underlying_Type (T1))
223 and then Is_Integer_Type (Underlying_Type (T2))
224 and then Is_Integer_Type (Underlying_Type (Ret))
230 ("types of intrinsic operator operands do not match", E, N);
233 -- Comparison operators
235 elsif Nam_In (Nam, Name_Op_Eq, Name_Op_Ge, Name_Op_Gt, Name_Op_Le,
236 Name_Op_Lt, Name_Op_Ne)
238 T1 := Etype (First_Formal (E));
240 -- Return if previous error in declaration, otherwise get T2 type
242 if No (Next_Formal (First_Formal (E))) then
243 Check_Error_Detected;
247 T2 := Etype (Next_Formal (First_Formal (E)));
250 if Root_Type (T1) /= Root_Type (T2) then
252 ("types of intrinsic operator must have the same size", E, N);
255 if Root_Type (Ret) /= Standard_Boolean then
257 ("result type of intrinsic comparison must be boolean", E, N);
262 elsif Nam = Name_Op_Expon then
263 T1 := Etype (First_Formal (E));
265 if No (Next_Formal (First_Formal (E))) then
267 -- Previous error in declaration
272 T2 := Etype (Next_Formal (First_Formal (E)));
275 if not (Is_Integer_Type (T1)
277 Is_Floating_Point_Type (T1))
278 or else Root_Type (T1) /= Root_Type (Ret)
279 or else Root_Type (T2) /= Root_Type (Standard_Integer)
281 Errint ("incorrect operands for intrinsic operator", N, E);
284 -- All other operators (are there any?) are not handled
287 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
291 -- The type must be fully defined and numeric.
293 if No (Underlying_Type (T1))
294 or else not Is_Numeric_Type (Underlying_Type (T1))
296 Errint ("intrinsic operator can only apply to numeric types", E, N);
298 end Check_Intrinsic_Operator;
300 --------------------------------
301 -- Check_Intrinsic_Subprogram --
302 --------------------------------
304 procedure Check_Intrinsic_Subprogram (E : Entity_Id; N : Node_Id) is
305 Spec : constant Node_Id := Specification (Unit_Declaration_Node (E));
310 and then Present (Generic_Parent (Spec))
312 Nam := Chars (Generic_Parent (Spec));
317 -- Check name is valid intrinsic name
319 Get_Name_String (Nam);
321 if Name_Buffer (1) /= 'O'
322 and then Nam /= Name_Asm
323 and then Nam /= Name_To_Address
324 and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
326 Errint ("unrecognized intrinsic subprogram", E, N);
328 -- Shift cases. We allow user specification of intrinsic shift operators
329 -- for any numeric types.
331 elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left,
332 Name_Shift_Right, Name_Shift_Right_Arithmetic)
336 -- We always allow intrinsic specifications in language defined units
337 -- and in expanded code. We assume that the GNAT implementors know what
338 -- they are doing, and do not write or generate junk use of intrinsic.
340 elsif not Comes_From_Source (E)
341 or else not Comes_From_Source (N)
342 or else Is_Predefined_File_Name
343 (Unit_File_Name (Get_Source_Unit (N)))
347 -- Exception functions
349 elsif Nam_In (Nam, Name_Exception_Information,
350 Name_Exception_Message,
353 Check_Exception_Function (E, N);
355 -- Intrinsic operators
357 elsif Nkind (E) = N_Defining_Operator_Symbol then
358 Check_Intrinsic_Operator (E, N);
360 -- Source_Location and navigation functions
362 elsif Nam_In (Nam, Name_File,
364 Name_Source_Location,
365 Name_Enclosing_Entity,
366 Name_Compilation_ISO_Date,
367 Name_Compilation_Date,
368 Name_Compilation_Time)
372 -- For now, no other intrinsic subprograms are recognized in user code
375 Errint ("incorrect context for ""Intrinsic"" convention", E, N);
377 end Check_Intrinsic_Subprogram;
383 procedure Check_Shift (E : Entity_Id; N : Node_Id) is
393 if not Ekind_In (E, E_Function, E_Generic_Function) then
394 Errint ("intrinsic shift subprogram must be a function", E, N);
398 Arg1 := First_Formal (E);
400 if Present (Arg1) then
401 Arg2 := Next_Formal (Arg1);
406 if Arg1 = Empty or else Arg2 = Empty then
407 Errint ("intrinsic shift function must have two arguments", E, N);
411 Typ1 := Etype (Arg1);
412 Typ2 := Etype (Arg2);
414 Ptyp1 := Parameter_Type (Parent (Arg1));
415 Ptyp2 := Parameter_Type (Parent (Arg2));
417 if not Is_Integer_Type (Typ1) then
418 Errint ("first argument to shift must be integer type", Ptyp1, N);
422 if Typ2 /= Standard_Natural then
423 Errint ("second argument to shift must be type Natural", Ptyp2, N);
427 -- type'Size (not 'Object_Size) must be one of the allowed values
429 Size := UI_To_Int (RM_Size (Typ1));
431 if Size /= 8 and then
437 ("first argument for shift must have size 8, 16, 32 or 64",
438 Ptyp1, N, Relaxed => True);
441 elsif Non_Binary_Modulus (Typ1) then
442 Errint ("shifts not allowed for nonbinary modular types", Ptyp1, N);
444 -- For modular type, modulus must be 2**8, 2**16, 2**32, or 2**64.
445 -- Don't apply to generic types, since we may not have a modulus value.
447 elsif Is_Modular_Integer_Type (Typ1)
448 and then not Is_Generic_Type (Typ1)
449 and then Modulus (Typ1) /= Uint_2 ** 8
450 and then Modulus (Typ1) /= Uint_2 ** 16
451 and then Modulus (Typ1) /= Uint_2 ** 32
452 and then Modulus (Typ1) /= Uint_2 ** 64
455 ("modular type for shift must have modulus of 2'*'*8, "
456 & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N, Relaxed => True);
458 elsif Etype (Arg1) /= Etype (E) then
460 ("first argument of shift must match return type", Ptyp1, N);
464 Set_Has_Shift_Operator (Base_Type (Typ1));
472 (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False) is
474 -- Ignore errors on Intrinsic in Relaxed_RM_Semantics mode where we can
477 if not (Relaxed and Relaxed_RM_Semantics) then
478 Error_Msg_N (Msg, S);
479 Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);