1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Errout
; use Errout
;
34 with Namet
; use Namet
;
36 with Sem_Aux
; use Sem_Aux
;
37 with Sem_Eval
; use Sem_Eval
;
38 with Sem_Util
; use Sem_Util
;
39 with Sinfo
; use Sinfo
;
40 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
41 with Sinfo
.Utils
; use Sinfo
.Utils
;
42 with Snames
; use Snames
;
43 with Stand
; use Stand
;
44 with Stringt
; use Stringt
;
45 with Ttypes
; use Ttypes
;
46 with Uintp
; use Uintp
;
48 package body Sem_Intr
is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 procedure Check_Exception_Function
(E
: Entity_Id
; N
: Node_Id
);
55 -- Check use of intrinsic Exception_Message, Exception_Info or
56 -- Exception_Name, as used in the DEC compatible Current_Exceptions
57 -- package. In each case we must have a parameterless function that
58 -- returns type String.
60 procedure Check_Intrinsic_Operator
(E
: Entity_Id
; N
: Node_Id
);
61 -- Check that operator is one of the binary arithmetic operators, and that
62 -- the types involved both have underlying integer types.
64 procedure Check_Shift
(E
: Entity_Id
; N
: Node_Id
);
65 -- Check intrinsic shift subprogram, the two arguments are the same
66 -- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
67 -- declaration, and the node for the pragma argument, used for messages).
70 (Msg
: String; S
: Node_Id
; N
: Node_Id
; Relaxed
: Boolean := False);
71 -- Post error message for bad intrinsic, the message itself is posted
72 -- on the appropriate spec node and another message is placed on the
73 -- pragma itself, referring to the spec. S is the node in the spec on
74 -- which the message is to be placed, and N is the pragma argument node.
75 -- Relaxed is True if the message should not be emitted in
76 -- Relaxed_RM_Semantics mode.
78 ------------------------------
79 -- Check_Exception_Function --
80 ------------------------------
82 procedure Check_Exception_Function
(E
: Entity_Id
; N
: Node_Id
) is
84 if Ekind
(E
) not in E_Function | E_Generic_Function
then
86 ("intrinsic exception subprogram must be a function", E
, N
);
88 elsif Present
(First_Formal
(E
)) then
90 ("intrinsic exception subprogram may not have parameters",
94 elsif Etype
(E
) /= Standard_String
then
96 ("return type of exception subprogram must be String", E
, N
);
99 end Check_Exception_Function
;
101 --------------------------
102 -- Check_Intrinsic_Call --
103 --------------------------
105 procedure Check_Intrinsic_Call
(N
: Node_Id
) is
106 Nam
: constant Entity_Id
:= Entity
(Name
(N
));
107 Arg1
: constant Node_Id
:= First_Actual
(N
);
109 Rtyp
: Entity_Id
:= Empty
;
114 -- Set argument type if argument present
116 if Present
(Arg1
) then
118 Rtyp
:= Underlying_Type
(Root_Type
(Typ
));
121 -- Set intrinsic name (getting original name in the generic case)
123 Unam
:= Ultimate_Alias
(Nam
);
125 if Present
(Parent
(Unam
))
126 and then Present
(Generic_Parent
(Parent
(Unam
)))
128 Cnam
:= Chars
(Generic_Parent
(Parent
(Unam
)));
133 -- For Import_xxx calls, argument must be static string. A string
134 -- literal is legal even in Ada 83 mode, where such literals are
137 if Cnam
in Name_Import_Address
138 | Name_Import_Largest_Value
141 if Etype
(Arg1
) = Any_Type
142 or else Raises_Constraint_Error
(Arg1
)
146 elsif Nkind
(Arg1
) /= N_String_Literal
147 and then not Is_OK_Static_Expression
(Arg1
)
150 ("call to & requires static string argument!", N
, Nam
);
151 Why_Not_Static
(Arg1
);
153 elsif String_Length
(Strval
(Expr_Value_S
(Arg1
))) = 0 then
155 ("call to & does not permit null string", N
, Nam
);
158 -- Check for the case of freeing a non-null object which will raise
159 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
161 elsif Cnam
= Name_Unchecked_Deallocation
162 and then Can_Never_Be_Null
(Etype
(Arg1
))
165 ("freeing `NOT NULL` object will raise Constraint_Error??", N
);
167 -- For unchecked deallocation, error to deallocate from empty pool.
168 -- Note: this test used to be in Exp_Intr as a warning, but AI 157
169 -- issues a binding interpretation that this should be an error, and
170 -- consequently it needs to be done in the semantic analysis so that
171 -- the error is issued even in semantics only mode.
173 elsif Cnam
= Name_Unchecked_Deallocation
174 and then No_Pool_Assigned
(Rtyp
)
176 Error_Msg_N
("deallocation from empty storage pool!", N
);
178 -- For now, no other special checks are required
183 end Check_Intrinsic_Call
;
185 ------------------------------
186 -- Check_Intrinsic_Operator --
187 ------------------------------
189 procedure Check_Intrinsic_Operator
(E
: Entity_Id
; N
: Node_Id
) is
190 Ret
: constant Entity_Id
:= Etype
(E
);
191 Nam
: constant Name_Id
:= Chars
(E
);
196 -- Arithmetic operators
198 if Nam
in Name_Op_Add | Name_Op_Subtract | Name_Op_Multiply |
199 Name_Op_Divide | Name_Op_Rem | Name_Op_Mod |
202 T1
:= Etype
(First_Formal
(E
));
204 if No
(Next_Formal
(First_Formal
(E
))) then
205 if Nam
in Name_Op_Add | Name_Op_Subtract | Name_Op_Abs
then
208 -- Previous error in declaration
215 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
218 -- Same types, predefined operator will apply
220 if Root_Type
(T1
) = Root_Type
(T2
)
221 or else Root_Type
(T1
) = Root_Type
(Ret
)
225 -- Expansion will introduce conversions if sizes are not equal
227 elsif Is_Integer_Type
(Underlying_Type
(T1
))
228 and then Is_Integer_Type
(Underlying_Type
(T2
))
229 and then Is_Integer_Type
(Underlying_Type
(Ret
))
235 ("types of intrinsic operator operands do not match", E
, N
);
238 -- Comparison operators
240 elsif Nam
in Name_Op_Eq | Name_Op_Ge | Name_Op_Gt | Name_Op_Le |
241 Name_Op_Lt | Name_Op_Ne
243 T1
:= Etype
(First_Formal
(E
));
245 -- Return if previous error in declaration, otherwise get T2 type
247 if No
(Next_Formal
(First_Formal
(E
))) then
248 Check_Error_Detected
;
252 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
255 if Root_Type
(T1
) /= Root_Type
(T2
) then
257 ("types of intrinsic operator must have the same size", E
, N
);
260 if Root_Type
(Ret
) /= Standard_Boolean
then
262 ("result type of intrinsic comparison must be boolean", E
, N
);
267 elsif Nam
= Name_Op_Expon
then
268 T1
:= Etype
(First_Formal
(E
));
270 if No
(Next_Formal
(First_Formal
(E
))) then
272 -- Previous error in declaration
277 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
280 if not (Is_Integer_Type
(T1
)
282 Is_Floating_Point_Type
(T1
))
283 or else Root_Type
(T1
) /= Root_Type
(Ret
)
284 or else Root_Type
(T2
) /= Root_Type
(Standard_Integer
)
286 Errint
("incorrect operands for intrinsic operator", N
, E
);
289 -- All other operators (are there any?) are not handled
292 Errint
("incorrect context for ""Intrinsic"" convention", E
, N
);
296 -- The type must be fully defined and numeric.
298 if No
(Underlying_Type
(T1
))
299 or else not Is_Numeric_Type
(Underlying_Type
(T1
))
301 Errint
("intrinsic operator can only apply to numeric types", E
, N
);
303 end Check_Intrinsic_Operator
;
305 --------------------------------
306 -- Check_Intrinsic_Subprogram --
307 --------------------------------
309 procedure Check_Intrinsic_Subprogram
(E
: Entity_Id
; N
: Node_Id
) is
310 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(E
));
315 and then Present
(Generic_Parent
(Spec
))
317 Nam
:= Chars
(Generic_Parent
(Spec
));
322 -- Check name is valid intrinsic name
324 Get_Name_String
(Nam
);
326 if Name_Buffer
(1) /= 'O'
327 and then Nam
/= Name_Asm
328 and then Nam
/= Name_To_Address
329 and then Nam
not in First_Intrinsic_Name
.. Last_Intrinsic_Name
331 Errint
("unrecognized intrinsic subprogram", E
, N
);
333 -- Shift cases. We allow user specification of intrinsic shift operators
334 -- for any numeric types.
336 elsif Nam
in Name_Rotate_Left | Name_Rotate_Right | Name_Shift_Left |
337 Name_Shift_Right | Name_Shift_Right_Arithmetic
341 -- We always allow intrinsic specifications in language defined units
342 -- and in expanded code. We assume that the GNAT implementors know what
343 -- they are doing, and do not write or generate junk use of intrinsic.
345 elsif not Comes_From_Source
(E
)
346 or else not Comes_From_Source
(N
)
347 or else In_Predefined_Unit
(N
)
351 -- Exception functions
353 elsif Nam
in Name_Exception_Information
354 | Name_Exception_Message
355 | Name_Exception_Name
357 Check_Exception_Function
(E
, N
);
359 -- Intrinsic operators
361 elsif Nkind
(E
) = N_Defining_Operator_Symbol
then
362 Check_Intrinsic_Operator
(E
, N
);
364 -- Source_Location and navigation functions
366 elsif Nam
in Name_File
368 | Name_Source_Location
369 | Name_Enclosing_Entity
370 | Name_Compilation_ISO_Date
371 | Name_Compilation_Date
372 | Name_Compilation_Time
376 -- For now, no other intrinsic subprograms are recognized in user code
379 Errint
("incorrect context for ""Intrinsic"" convention", E
, N
);
381 end Check_Intrinsic_Subprogram
;
387 procedure Check_Shift
(E
: Entity_Id
; N
: Node_Id
) is
397 if Ekind
(E
) not in E_Function | E_Generic_Function
then
398 Errint
("intrinsic shift subprogram must be a function", E
, N
);
402 Arg1
:= First_Formal
(E
);
404 if Present
(Arg1
) then
405 Arg2
:= Next_Formal
(Arg1
);
410 if Arg1
= Empty
or else Arg2
= Empty
then
411 Errint
("intrinsic shift function must have two arguments", E
, N
);
415 Typ1
:= Etype
(Arg1
);
416 Typ2
:= Etype
(Arg2
);
418 Ptyp1
:= Parameter_Type
(Parent
(Arg1
));
419 Ptyp2
:= Parameter_Type
(Parent
(Arg2
));
421 if not Is_Integer_Type
(Typ1
) then
422 Errint
("first argument to shift must be integer type", Ptyp1
, N
);
426 if Typ2
/= Standard_Natural
then
427 Errint
("second argument to shift must be type Natural", Ptyp2
, N
);
431 -- type'Size (not 'Object_Size) must be one of the allowed values
433 Size
:= UI_To_Int
(RM_Size
(Typ1
));
435 if Size
/= 8 and then
439 Size
/= System_Max_Integer_Size
441 if System_Max_Integer_Size
> 64 then
443 ("first argument for shift must have size 8, 16, 32, 64 or 128",
444 Ptyp1
, N
, Relaxed
=> True);
447 ("first argument for shift must have size 8, 16, 32 or 64",
448 Ptyp1
, N
, Relaxed
=> True);
452 elsif Non_Binary_Modulus
(Typ1
) then
453 Errint
("shifts not allowed for nonbinary modular types", Ptyp1
, N
);
455 -- For modular type, modulus must be 2**8, 2**16, 2**32, or 2**64.
456 -- Don't apply to generic types, since we may not have a modulus value.
458 elsif Is_Modular_Integer_Type
(Typ1
)
459 and then not Is_Generic_Type
(Typ1
)
460 and then Modulus
(Typ1
) /= Uint_2
** 8
461 and then Modulus
(Typ1
) /= Uint_2
** 16
462 and then Modulus
(Typ1
) /= Uint_2
** 32
463 and then Modulus
(Typ1
) /= Uint_2
** 64
464 and then Modulus
(Typ1
) /= Uint_2
** System_Max_Binary_Modulus_Power
466 if System_Max_Binary_Modulus_Power
> 64 then
468 ("modular type for shift must have modulus of 2'*'*8, "
469 & "2'*'*16, 2'*'*32, 2'*'*64 or 2'*'*128", Ptyp1
, N
,
473 ("modular type for shift must have modulus of 2'*'*8, "
474 & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1
, N
,
478 elsif Etype
(Arg1
) /= Etype
(E
) then
480 ("first argument of shift must match return type", Ptyp1
, N
);
484 Set_Has_Shift_Operator
(Base_Type
(Typ1
));
492 (Msg
: String; S
: Node_Id
; N
: Node_Id
; Relaxed
: Boolean := False) is
494 -- Ignore errors on Intrinsic in Relaxed_RM_Semantics mode where we can
497 if not (Relaxed
and Relaxed_RM_Semantics
) then
498 Error_Msg_N
(Msg
, S
);
499 Error_Msg_N
("incorrect intrinsic subprogram, see spec", N
);