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_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 Targparm
; use Targparm
;
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)
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.
71 ------------------------------
72 -- Check_Exception_Function --
73 ------------------------------
75 procedure Check_Exception_Function
(E
: Entity_Id
; N
: Node_Id
) is
77 if not Ekind_In
(E
, E_Function
, E_Generic_Function
) then
79 ("intrinsic exception subprogram must be a function", E
, N
);
81 elsif Present
(First_Formal
(E
)) then
83 ("intrinsic exception subprogram may not have parameters",
87 elsif Etype
(E
) /= Standard_String
then
89 ("return type of exception subprogram must be String", E
, N
);
92 end Check_Exception_Function
;
94 --------------------------
95 -- Check_Intrinsic_Call --
96 --------------------------
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
);
107 -- Set argument type if argument present
109 if Present
(Arg1
) then
111 Rtyp
:= Underlying_Type
(Root_Type
(Typ
));
114 -- Set intrinsic name (getting original name in the generic case)
116 Unam
:= Ultimate_Alias
(Nam
);
118 if Present
(Parent
(Unam
))
119 and then Present
(Generic_Parent
(Parent
(Unam
)))
121 Cnam
:= Chars
(Generic_Parent
(Parent
(Unam
)));
126 -- For Import_xxx calls, argument must be static string. A string
127 -- literal is legal even in Ada83 mode, where such literals are
130 if Cnam
= Name_Import_Address
132 Cnam
= Name_Import_Largest_Value
134 Cnam
= Name_Import_Value
136 if Etype
(Arg1
) = Any_Type
137 or else Raises_Constraint_Error
(Arg1
)
141 elsif Nkind
(Arg1
) /= N_String_Literal
142 and then not Is_Static_Expression
(Arg1
)
145 ("call to & requires static string argument!", N
, Nam
);
146 Why_Not_Static
(Arg1
);
148 elsif String_Length
(Strval
(Expr_Value_S
(Arg1
))) = 0 then
150 ("call to & does not permit null string", N
, Nam
);
152 elsif OpenVMS_On_Target
153 and then String_Length
(Strval
(Expr_Value_S
(Arg1
))) > 31
156 ("argument in call to & must be 31 characters or less", N
, Nam
);
159 -- Check for the case of freeing a non-null object which will raise
160 -- Constraint_Error. Issue warning here, do the expansion in Exp_Intr.
162 elsif Cnam
= Name_Unchecked_Deallocation
163 and then Can_Never_Be_Null
(Etype
(Arg1
))
166 ("freeing `NOT NULL` object will raise Constraint_Error?", N
);
168 -- For unchecked deallocation, error to deallocate from empty pool.
169 -- Note: this test used to be in Exp_Intr as a warning, but AI 157
170 -- issues a binding intepretation that this should be an error, and
171 -- consequently it needs to be done in the semantic analysis so that
172 -- the error is issued even in semantics only mode.
174 elsif Cnam
= Name_Unchecked_Deallocation
175 and then No_Pool_Assigned
(Rtyp
)
177 Error_Msg_N
("deallocation from empty storage pool!", N
);
179 -- For now, no other special checks are required
184 end Check_Intrinsic_Call
;
186 ------------------------------
187 -- Check_Intrinsic_Operator --
188 ------------------------------
190 procedure Check_Intrinsic_Operator
(E
: Entity_Id
; N
: Node_Id
) is
191 Ret
: constant Entity_Id
:= Etype
(E
);
192 Nam
: constant Name_Id
:= Chars
(E
);
197 -- Arithmetic operators
201 Nam
= Name_Op_Subtract
203 Nam
= Name_Op_Multiply
213 T1
:= Etype
(First_Formal
(E
));
215 if No
(Next_Formal
(First_Formal
(E
))) then
219 Nam
= Name_Op_Subtract
225 -- Previous error in declaration
232 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
235 -- Same types, predefined operator will apply
237 if Root_Type
(T1
) = Root_Type
(T2
)
238 or else Root_Type
(T1
) = Root_Type
(Ret
)
242 -- Expansion will introduce conversions if sizes are not equal
244 elsif Is_Integer_Type
(Underlying_Type
(T1
))
245 and then Is_Integer_Type
(Underlying_Type
(T2
))
246 and then Is_Integer_Type
(Underlying_Type
(Ret
))
252 ("types of intrinsic operator operands do not match", E
, N
);
255 -- Comparison operators
257 elsif Nam
= Name_Op_Eq
269 T1
:= Etype
(First_Formal
(E
));
271 -- Return if previous error in declaration, otherwise get T2 type
273 if No
(Next_Formal
(First_Formal
(E
))) then
276 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
279 if Root_Type
(T1
) /= Root_Type
(T2
) then
281 ("types of intrinsic operator must have the same size", E
, N
);
284 if Root_Type
(Ret
) /= Standard_Boolean
then
286 ("result type of intrinsic comparison must be boolean", E
, N
);
291 elsif Nam
= Name_Op_Expon
then
292 T1
:= Etype
(First_Formal
(E
));
294 if No
(Next_Formal
(First_Formal
(E
))) then
296 -- Previous error in declaration
301 T2
:= Etype
(Next_Formal
(First_Formal
(E
)));
304 if not (Is_Integer_Type
(T1
)
306 Is_Floating_Point_Type
(T1
))
307 or else Root_Type
(T1
) /= Root_Type
(Ret
)
308 or else Root_Type
(T2
) /= Root_Type
(Standard_Integer
)
310 Errint
("incorrect operands for intrinsic operator", N
, E
);
313 -- All other operators (are there any?) are not handled
316 Errint
("incorrect context for ""Intrinsic"" convention", E
, N
);
320 if not Is_Numeric_Type
(Underlying_Type
(T1
)) then
321 Errint
("intrinsic operator can only apply to numeric types", E
, N
);
323 end Check_Intrinsic_Operator
;
325 --------------------------------
326 -- Check_Intrinsic_Subprogram --
327 --------------------------------
329 procedure Check_Intrinsic_Subprogram
(E
: Entity_Id
; N
: Node_Id
) is
330 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(E
));
335 and then Present
(Generic_Parent
(Spec
))
337 Nam
:= Chars
(Generic_Parent
(Spec
));
342 -- Check name is valid intrinsic name
344 Get_Name_String
(Nam
);
346 if Name_Buffer
(1) /= 'O'
347 and then Nam
/= Name_Asm
348 and then Nam
/= Name_To_Address
349 and then Nam
not in First_Intrinsic_Name
.. Last_Intrinsic_Name
351 Errint
("unrecognized intrinsic subprogram", E
, N
);
353 -- We always allow intrinsic specifications in language defined units
354 -- and in expanded code. We assume that the GNAT implementors know what
355 -- they are doing, and do not write or generate junk use of intrinsic!
357 elsif not Comes_From_Source
(E
)
358 or else not Comes_From_Source
(N
)
359 or else Is_Predefined_File_Name
360 (Unit_File_Name
(Get_Source_Unit
(N
)))
364 -- Shift cases. We allow user specification of intrinsic shift
365 -- operators for any numeric types.
368 Nam
= Name_Rotate_Left
370 Nam
= Name_Rotate_Right
372 Nam
= Name_Shift_Left
374 Nam
= Name_Shift_Right
376 Nam
= Name_Shift_Right_Arithmetic
381 Nam
= Name_Exception_Information
383 Nam
= Name_Exception_Message
385 Nam
= Name_Exception_Name
387 Check_Exception_Function
(E
, N
);
389 elsif Nkind
(E
) = N_Defining_Operator_Symbol
then
390 Check_Intrinsic_Operator
(E
, N
);
392 elsif Nam
= Name_File
393 or else Nam
= Name_Line
394 or else Nam
= Name_Source_Location
395 or else Nam
= Name_Enclosing_Entity
399 -- For now, no other intrinsic subprograms are recognized in user code
402 Errint
("incorrect context for ""Intrinsic"" convention", E
, N
);
404 end Check_Intrinsic_Subprogram
;
410 procedure Check_Shift
(E
: Entity_Id
; N
: Node_Id
) is
420 if not Ekind_In
(E
, E_Function
, E_Generic_Function
) then
421 Errint
("intrinsic shift subprogram must be a function", E
, N
);
425 Arg1
:= First_Formal
(E
);
427 if Present
(Arg1
) then
428 Arg2
:= Next_Formal
(Arg1
);
433 if Arg1
= Empty
or else Arg2
= Empty
then
434 Errint
("intrinsic shift function must have two arguments", E
, N
);
438 Typ1
:= Etype
(Arg1
);
439 Typ2
:= Etype
(Arg2
);
441 Ptyp1
:= Parameter_Type
(Parent
(Arg1
));
442 Ptyp2
:= Parameter_Type
(Parent
(Arg2
));
444 if not Is_Integer_Type
(Typ1
) then
445 Errint
("first argument to shift must be integer type", Ptyp1
, N
);
449 if Typ2
/= Standard_Natural
then
450 Errint
("second argument to shift must be type Natural", Ptyp2
, N
);
454 Size
:= UI_To_Int
(Esize
(Typ1
));
462 ("first argument for shift must have size 8, 16, 32 or 64",
466 elsif Non_Binary_Modulus
(Typ1
) then
468 ("shifts not allowed for non-binary modular types",
471 elsif Etype
(Arg1
) /= Etype
(E
) then
473 ("first argument of shift must match return type", Ptyp1
, N
);
482 procedure Errint
(Msg
: String; S
: Node_Id
; N
: Node_Id
) is
484 Error_Msg_N
(Msg
, S
);
485 Error_Msg_N
("incorrect intrinsic subprogram, see spec", N
);